I am trying to run a regression model that includes fixed effects for cities in the united states. I have over 10,000,000 million rows and 600 cities. The code below works, but it is really slow. When including a factor for a variable with lots of levels, is there any way to run the model faster.
x <- data.frame(
a = sample( 1:1000, 1000000 , replace=T),
cityfips = sample( 1:250, 1000000 , replace=T),
d = sample( 1:4, 1000000 , replace=T)
)
system.time(a1 <- lm( a~cityfips+d , x ) )
system.time(a2 <- lm( a~as.factor(cityfips) + d , x ) )
> system.time(a1 <- lm( a~cityfips+d , x ) )
user system elapsed
0.22 0.00 0.22
> system.time(a2 <- lm( a~as.factor(cityfips) + d , x ) )
user system elapsed
95.65 0.97 96.62
> system.time(a3 <- slm( a~as.factor(cityfips) + d , x ) )
user system elapsed
4.58 2.06 6.65
When you have that many factors, constructing the model.matrix in lm() will take up most of the time, one way is to use sparseMatrix like in glmnet and there are two packages, sparseM, MatrixModels that allows lm onto sparseMatrix:
set.seed(111)
x <- data.frame(
a = sample( 1:1000, 1000000 , replace=T),
cityfips = sample( 1:250, 1000000 , replace=T),
d = sample( 1:4, 1000000 , replace=T)
)
library(SparseM)
library(MatrixModels)
library(Matrix)
system.time(f_lm <- lm( a~as.factor(cityfips) + d , x ) )
user system elapsed
75.720 2.494 79.365
system.time(f_sparseM <- slm(a~as.factor(cityfips) + d , x ))
user system elapsed
5.373 3.952 10.646
system.time(f_modelMatrix <- glm4(a~as.factor(cityfips) + d ,data=x,sparse=TRUE))
user system elapsed
1.878 0.335 2.219
The closest I can find is glm4 in MatrixModels, but you can see below the coefficients are the same as the fit using lm:
all.equal(as.numeric(f_sparseM$coefficients),as.numeric(f_lm$coefficients))
[1] TRUE
all.equal(as.numeric(f_lm$coefficients),as.numeric(coefficients(f_modelMatrix)))
[1] TRUE
One other option besides glm4 in MatrixModels is to use lm.fit (as pointed out by #BenBolker:
lm.fit(x=Matrix::sparse.model.matrix(~as.factor(cityfips) + d,data=x),y=x$a)
This gives you a list as like lm.fit() normally and you cannot apply functions such as summary() etc.
Authors of both package warn about it being experimental so there might still be some differences compared to stats::lm , take care to check.
check out the lfe package. I've not dug into the details of the algorithm but at least in my experience it's produced exactly the same results as lm() in fractions of the time.
as a bonus it makes it easy to cluster standard errors so you don't need to do any clustering and/or sandwich estimator business afterward, although the syntax for doing so is a little unusual
Related
I'm wondering if there is a way to extract R2 for each regression equation.
d <- data.frame(
state = rep(c('NY', 'CA'), 10),
year = rep(1:10, 2),
response= rnorm(20)
)
library(plyr)
models <- dlply(d, "state", function(df)
lm(response ~ year, data = df))
ldply(models, coef)
l_ply(models, summary, .print = TRUE)
I tried
l_ply(models, summary$r.squared, .print = TRUE)
But this throws the following error message
Error in summary$r.squared : object of type 'closure' is not subsettable
You can do this to get the R squared value and the coefficients:
ldply(models, function(x) {r.sq <- summary(x)$r.squared
intercept <- summary(x)$coefficients[1]
beta <- summary(x)$coefficients[2]
data.frame(r.sq, intercept, beta)})
# state r.sq intercept beta
#1 CA 0.230696121 0.4915617 -0.12343947
#2 NY 0.003506936 0.1971734 -0.01227367
Using the broom package for converting statistical analysis objects into data.frames and dplyr for bind_rows:
library(dplyr) ; library(broom)
cbind(
state = attr(models, "split_labels"),
bind_rows(lapply(models, function(x) cbind(
intercept = tidy(x)$estimate[1],
beta = tidy(x)$estimate[2],
glance(x))))
)
state intercept beta r.squared adj.r.squared sigma statistic p.value df logLik AIC BIC deviance df.residual
1 CA 0.38653551 -0.05459205 0.01427426 -0.10894146 1.434599 0.1158477 0.7423473 2 -16.68252 39.36505 40.27280 16.46460 8
2 NY 0.09028554 -0.08462742 0.04138985 -0.07843642 1.287909 0.3454155 0.5729312 2 -15.60387 37.20773 38.11549 13.26968 8
you can try this
sapply(models, function(x) summary(x)$r.squared)
CA NY
0.05639 0.23751
If you try
> typeof( summary )
[1] "closure"
you see that 'summary' is a function. You are trying to access a field of the result, but summary$r.squared tries to access that field on the function / closure.
Using an anonymous function,
> l_ply( models, function( m ) summary( m )$r.squared, .print = TRUE )
[1] 0.2319583
[1] 0.01295825
will work and print the result. However, you say that you want to "extract the result". This probably means that you want to use the result and not just print it.
From the documentation of l_ply (which you'll get by typing ?l_ply at the R prompt):
For each element of a list, apply function and discard results.
(So this function will not work if you want to hang on to the result.)
Using the standard sapply/lapply will result in
> a <- sapply( models, function( t ) summary( t )$r.squared )
> a
CA NY
0.23195825 0.01295825
> typeof( a )
[1] "double"
> is.vector( a )
[1] TRUE
> # or alternatively
> l <- lapply( models, function( t ) summary( t )$r.squared )
> l
$CA
[1] 0.2319583
$NY
[1] 0.01295825
> typeof( l )
[1] "list"
Either one should work -- pick whichever result (vector or list) is easier to use for what you want to do. (If unsure, just pick sapply.)
(Or, if you want to use functions from the plyr package, laply, ldply, and llply seem to work too. But I've never used that package, so I can't say what's best.)
I have 500K users and I need to compute a linear regression (with intercept) for each of them.
Each user has around 30 records.
I tried with dplyr and lm and this is way too slow.
Around 2 sec by user.
df%>%
group_by(user_id, add = FALSE) %>%
do(lm = lm(Y ~ x, data = .)) %>%
mutate(lm_b0 = summary(lm)$coeff[1],
lm_b1 = summary(lm)$coeff[2]) %>%
select(user_id, lm_b0, lm_b1) %>%
ungroup()
)
I tried to use lm.fit which is known to be faster but it doesn't seem to be compatible with dplyr.
Is there a fast way to do a linear regression by group?
You can just use the basic formulas for calculating slope and regression. lm does a lot of unnecessary things if all you care about are those two numbers. Here I use data.table for the aggregation, but you could do it in base R as well (or dplyr):
system.time(
res <- DT[,
{
ux <- mean(x)
uy <- mean(y)
slope <- sum((x - ux) * (y - uy)) / sum((x - ux) ^ 2)
list(slope=slope, intercept=uy - slope * ux)
}, by=user.id
]
)
Produces for 500K users ~30 obs each (in seconds):
user system elapsed
7.35 0.00 7.36
Or about 15 microseconds per user.
Update: I ended up writing a bunch of blog posts that touch on this as well.
And to confirm this is working as expected:
> summary(DT[user.id==89663, lm(y ~ x)])$coefficients
Estimate Std. Error t value Pr(>|t|)
(Intercept) 0.1965844 0.2927617 0.6714826 0.5065868
x 0.2021210 0.5429594 0.3722580 0.7120808
> res[user.id == 89663]
user.id slope intercept
1: 89663 0.202121 0.1965844
Data:
set.seed(1)
users <- 5e5
records <- 30
x <- runif(users * records)
DT <- data.table(
x=x, y=x + runif(users * records) * 4 - 2,
user.id=sample(users, users * records, replace=T)
)
If all you want is coefficients, I'd just use user_id as a factor in the regression. Using #miles2know's simulated data code (though renaming since an object other than exp() sharing that name looks weird to me)
dat <- data.frame(id = rep(c("a","b","c"), each = 20),
x = rnorm(60,5,1.5),
y = rnorm(60,2,.2))
mod = lm(y ~ x:id + id + 0, data = dat)
We fit no global intercept (+ 0) so that the intercept for each id is the id coefficient, and no x by itself, so that the x:id interactions are the slopes for each id:
coef(mod)
# ida idb idc x:ida x:idb x:idc
# 1.779686 1.893582 1.946069 0.039625 0.033318 0.000353
So, for the a level of id, the ida coefficient, 1.78, is the intercept and the x:ida coefficient, 0.0396, is the slope.
I'll leave the gathering of these coefficients into appropriate columns of a data frame to you...
This solution should be very fast because you're not having to deal with subsets of data frames. It could probably be sped up even more with fastLm or such.
Note on scalability:
I did just try this on #nrussell's simulated full-size data and ran into memory allocation issues. Depending on how much memory you have it may not work in one go, but you could probably do it in batches of user ids. Some combination of his answer and my answer might be the fastest overall---or nrussell's might just be faster---expanding the user id factor into thousands of dummy variables might not be computationally efficient, as I've been waiting more than a couple minutes now for a run on just 5000 user ids.
Update:
As pointed out by Dirk, my original approach can be greatly improved upon by specifying x and Y directly rather than using the formula-based interface of fastLm, which incurs (a fairly significant) processing overhead. For comparison, using the original full size data set,
R> system.time({
dt[,c("lm_b0", "lm_b1") := as.list(
unname(fastLm(x, Y)$coefficients))
,by = "user_id"]
})
# user system elapsed
#55.364 0.014 55.401
##
R> system.time({
dt[,c("lm_b0","lm_b1") := as.list(
unname(fastLm(Y ~ x, data=.SD)$coefficients))
,by = "user_id"]
})
# user system elapsed
#356.604 0.047 356.820
this simple change yields roughly a 6.5x speedup.
[Original approach]
There is probably some room for improvement, but the following took about 25 minutes on a Linux VM (2.6 GHz processor), running 64-bit R:
library(data.table)
library(RcppArmadillo)
##
dt[
,c("lm_b0","lm_b1") := as.list(
unname(fastLm(Y ~ x, data=.SD)$coefficients)),
by=user_id]
##
R> dt[c(1:2, 31:32, 61:62),]
user_id x Y lm_b0 lm_b1
1: 1 1.0 1674.8316 -202.0066 744.6252
2: 1 1.5 369.8608 -202.0066 744.6252
3: 2 1.0 463.7460 -144.2961 374.1995
4: 2 1.5 412.7422 -144.2961 374.1995
5: 3 1.0 513.0996 217.6442 261.0022
6: 3 1.5 1140.2766 217.6442 261.0022
Data:
dt <- data.table(
user_id = rep(1:500000,each=30))
##
dt[, x := seq(1, by=.5, length.out=30), by = user_id]
dt[, Y := 1000*runif(1)*x, by = user_id]
dt[, Y := Y + rnorm(
30,
mean = sample(c(-.05,0,0.5)*mean(Y),1),
sd = mean(Y)*.25),
by = user_id]
You might give this a try using data.table like this. I've just created some toy data but I'd imagine data.table would give some improvement. It's quite speedy. But that is quite a large data-set so perhaps benchmark this approach on a smaller sample to see if the speed is a lot better. good luck.
library(data.table)
exp <- data.table(id = rep(c("a","b","c"), each = 20), x = rnorm(60,5,1.5), y = rnorm(60,2,.2))
# edit: it might also help to set a key on id with such a large data-set
# with the toy example it would make no diff of course
exp <- setkey(exp,id)
# the nuts and bolts of the data.table part of the answer
result <- exp[, as.list(coef(lm(y ~ x))), by=id]
result
id (Intercept) x
1: a 2.013548 -0.008175644
2: b 2.084167 -0.010023549
3: c 1.907410 0.015823088
An example using Rfast.
Assuming a single response and 500K predictor variables.
y <- rnorm(30)
x <- matrnorm(500*1000,30)
system.time( Rfast::univglms(y, x,"normal") ) ## 0.70 seconds
Assuming 500K response variables and a singl predictor variable.
system.time( Rfast::mvbetas(x,y) ) ## 0.60 seconds
Note: The above times will decrease in the nearby future.
Short question: is it possible to use matrix-wise operations in caretSBF$score function?
Motivation: When working with big matrices in R, operations that work natively matrix-wise [e.g. rowMeans(X) ] are often much faster than one-row-at-a-time approaches [e.g. apply(X, 1, mean) ]. Here is a benchmark example, using a matrix with a million rows and 100 columns:
rows = 1000000
cols = 100
X <- matrix(rnorm(rows*cols),nrow = rows)
ptm <- proc.time()
tt <- apply(X, 1, function(x) { t.test(x[1:50],x[51:100], var.equal = FALSE)$p.value })
proc.time() - ptm
# user system elapsed
# 312.420 0.685 313.633
library(genefilter)
ptm <- proc.time()
ftt <- rowFtests(X, fac = factor(c(rep(0,50), rep(1,50))), var.equal=FALSE)
proc.time() - ptm
# user system elapsed
# 21.400 1.336 23.257
Details: In the caret package, the caretSBF functions score and filter can be used to select features for cross-validated modeling. I want to use a custom scoring function in place of caretSBF$score (this part I can do), but I want it to be matrix-wise (like above -- this part I can't do). When I first looked at the functions, I couldn't see obvious reason why this wouldn't work. I want to do something like this:
mySBF$score <- function(x, y) {
genefilter::rowFtests(x, fac = y)$p.value
}
In place of the default:
$score
function (x, y)
{
if (is.factor(y))
anovaScores(x, y)
else gamScores(x, y)
}
<environment: namespace:caret>
But I can't make it work. Are matrix-wise operations just not supported by caretSBF?
Are matrix-wise operations just not supported by caretSBF?
No, not really. The score function is only served one predictor at a time.
However, you can get there using custom models in train. Here is an example that conducts feature extraction prior to modeling. You can adapt this with a multivariate filter and use the subset to fit the model. Here is a really crappy example:
> library(caret)
> set.seed(1)
> training <- LPH07_1(200)
>
> crappy <- getModelInfo("lm", regex = FALSE)[[1]]
> crappy$fit <- function (x, y, wts, param, lev, last, classProbs, ...) {
+ dat <- if (is.data.frame(x)) x else as.data.frame(x)
+ ## randomly filter all but 3 predictors
+ dat <- dat[, sample(1:ncol(dat), 3)]
+ dat$.outcome <- y
+ lm(.outcome ~ ., data = dat, ...)
+ }
> crappy$predict <- function (modelFit, newdata, submodels = NULL) {
+ if (!is.data.frame(newdata))
+ newdata <- as.data.frame(newdata)
## make sure to apply the subsetting part here too
+ predict(modelFit, newdata[, predictors(modelFit$terms)])
+ }
>
>
> mod <- train(y ~ ., data = training,
+ method = crappy)
> mod
Linear Regression
200 samples
10 predictor
No pre-processing
Resampling: Bootstrapped (25 reps)
Summary of sample sizes: 200, 200, 200, 200, 200, 200, ...
Resampling results
RMSE Rsquared RMSE SD Rsquared SD
3.08 0.077 0.258 0.0864
> predictors(mod)
[1] "Var08" "Var03" "Var04"
Max
I am just trying to understand the lasso implemented in R package glmnet.
I am fitting the data but the solution I get for a lambda of my choice is
not minimising the criteria of the lasso, for instance if I move the solution in one way
I can get a smaller cost function.
What am i understanding wrong?
library(lattice)
library(Matrix)
library(glmnet)
# Target vector
Target <- c(1.3906275E7, -1.8241672E7, 8181847.0, 1.6927098E7, -6547966.5, -1363836.375)
# Observation vector
Obs <- matrix(c( -0.944, 0.869 ,-0.795,-0.996, 0.617, 0.886,
-0.472 , 0.936 , 0.063 ,-0.080,-0.751 ,-0.834,
-0.107 , 0.343 , 0.261 , 0.327,-0.255,0.705,
-1.803,-0.781,0.168,0.211,-0.349, -0.040),6,4)
#fitting
fits <-glmnet(Obs,Target)
# arbitrary choice of lambda
lambda <- 221800
coef = predict(fits,s = lambda ,type="coefficients")
res = c(coef[2,1],coef[3,1],coef[4,1],coef[5,1])
# Computing the lasso criteria
newbookrisklassor = Target-Obs%*%res
cost = sum(abs(res))
newRisklassor = t(newbookrisklassor) %*% newbookrisklassor+lambda*cost
# Moving solution slightly in 1 way and computing the lasso criteria
epsilon = 500000
resP = res + c(0,epsilon,0,0)
costP = sum(abs(resP))
newbookrisklassorP = Target-Obs%*%resP
newRisklassorP = t(newbookrisklassorP) %*% newbookrisklassorP+lambda*costP
# Error it seems that the resP solution is better
newRisklassor-newRisklassorP
You should add the intercept in the fitting
newbookrisklassor = Target-Obs%*%res- intercept...
I'm using either dyn or dynlm to predict time series using lagged variables.
However, the predict function in either case only evaluates one time step at a time, taking a constant time of 24 milliseconds per step on my computer, or about 1.8 hours for my dataset, which is super long, given that the entire regression takes about 10 seconds.
So, I'm thinking that perhaps the fastest thing might be just to evaluate the formula by hand?
So, is there some way of evaluating a formula given values in a data.frame or the current envrironment or similar?
I'm thinking of something along the lines of:
evalMagic( load ~ temperature + time, data.frame( temperature = 10, time = 4 ) )
I suppose, as I write this, that we need to handle the coefficients somehow, something like:
evalMagic( load ~ temperature + time, data.frame( temperature = 10, time = 4 ), model$coefficients )
.... so this raises the questions of:
isn't this what predict is supposed to do?
why is predict so slow?
what options do I have to make the prediction a bit faster? After all, it's not inverting any matrices or something, it's just a bit of arithmetic!
I wrote my own lag implementation in the end. It's hacky and not beautiful, but it's a lot faster. It can process 1000 rows in 4 seconds on my crappy laptop.
# lags is a data.frame, eg:
# var amount
# y 1
# y 2
addLags <- function( dataset, lags ) {
N <- nrow(dataset)
print(lags)
if( nrow(lags) > 0 ) {
print(lags)
for( j in 1:nrow(lags) ) {
sourcename <- as.character( lags[j,"var"] )
k <- lags[j,"amount"]
cat("k",k,"sourcename",sourcename,"\n")
lagcolname <- sprintf("%s_%d",sourcename,k)
dataset[,lagcolname] <- c(rep(0,k), dataset[1:(N-k),sourcename])
}
}
dataset
}
lmLagged <- function( formula, train, lags ) {
# get largest lag, and skip that
N <- nrow(train)
skip <- 0
for( j in 1:nrow(lags) ) {
k <- lags[j,"amount"]
skip <- max(k,skip)
}
print(train)
train <- addLags( train, lags )
print(train)
lm( formula, train[(skip+1):N,] )
}
# pass in training data, test data,
# it will step through one by one
# need to give dependent var name
# lags is a data.frame, eg:
# var amount
# y 1
# y 2
predictLagged <- function( model, train, test, dependentvarname, lags ) {
Ntrain <- nrow(train)
Ntest <- nrow(test)
test[,dependentvarname] <- NA
testtraindata <- rbind( train, test )
testtraindata <- addLags( testtraindata, lags )
for( i in 1:Ntest ) {
thistestdata <- testtraindata[Ntrain + i,]
result <- predict(model,newdata=thistestdata)
for( j in 1:nrow(lags) ) {
sourcename <- lags[j,"var"]
k <- lags[j,"amount"]
lagcolname <- sprintf("%s_%d",sourcename,k)
testtraindata[Ntrain + i + k,lagcolname] <- result
}
testtraindata[Ntrain+i,dependentvarname] <- result
}
return( testtraindata[(Ntrain+1):(Ntrain + Ntest),dependentvarname] )
}
library("RUnit")
# size of training data
N <- 6
predictN <- 50
# create training data, which we can get exact fit on
set.seed(1)
x = sample( 100, N )
traindata <- numeric()
traindata[1] <- 1 + 1.1 * x[1]
traindata[2] <- 2 + 1.1 * x[2]
for( i in 3:N ) {
traindata[i] <- 0.5 + 0.3 * traindata[i-2] - 0.8 * traindata[i-1] + 1.1 * x[i]
}
train <- data.frame(x = x, y = traindata, foo = 1)
#train$x <- NULL
# create testing data, bunch of NAs
test <- data.frame( x = sample(100,predictN), y = rep(NA,predictN), foo = 1)
# specify which lags we need to handle
# one row per lag, with name of variable we are lagging, and the distance
# we can then use these in the formula, eg y_1, and y_2
# are y lagged by 1 and 2 respectively
# It's hacky but it kind of works...
lags <- data.frame( var = c("y","y"), amount = c(1,2) )
# fit a model
model <- lmLagged( y ~ x + y_1 + y_2, train, lags )
# look at the model, it's a perfect fit. Nice!
print(model)
print(system.time( test <- predictLagged( model, train, test, "y", lags ) ))
#checkEqualsNumeric( 69.10228, test[56-6], tolerance = 0.0001 )
#checkEquals( 2972.159, test$y[106-6] )
print(test)
# nice plot
plot(test, type='l')
Output:
> source("test/test.regressionlagged.r",echo=F)
Call:
lm(formula = formula, data = train[(skip + 1):N, ])
Coefficients:
(Intercept) x y_1 y_2
0.5 1.1 -0.8 0.3
user system elapsed
0.204 0.000 0.204
[1] -19.108620 131.494916 -42.228519 80.331290 -54.433588 86.846257
[7] -13.807082 77.199543 12.698241 64.101270 56.428457 72.487616
[13] -3.161555 99.575529 8.991110 44.079771 28.433517 3.077118
[19] 30.768361 12.008447 2.323751 36.343533 67.822299 -13.154779
[25] 72.070513 -11.602844 115.003429 -79.583596 164.667906 -102.309403
[31] 193.347894 -176.071136 254.361277 -225.010363 349.216673 -299.076448
[37] 400.626160 -371.223862 453.966938 -420.140709 560.802649 -542.284332
[43] 701.568260 -679.439907 839.222404 -773.509895 897.474637 -935.232679
[49] 1022.328534 -991.232631
There's about 12 hours work in those 91 lines of code. Ok, I confess I played Plants and Zombies for a bit. So, 10 hours. Plus lunch and dinner. Still, quite a lot of work anyway.
If we change predictN to 1000, I get about 4.1 seconds from the system.time call.
I think it's faster because:
we don't use timeseries; I suspect that speeds things up
we don't use dynamic lm libraries, just normal lm; I guess that's slightly faster
we only pass a single row of data into predict for each prediction, which I think is significantly faster, eg using dyn$lm or dynmlm, if one has a lag of 30, one would need to pass 31 rows of data into predict AFAIK
a lot less data.frame/matrix copying, since we just update the lag values in-place on each iteration
Edit: corrected minor buggette where predictLagged returned a multi-column data-frame instead of just a numeric vector
Edit2: corrected less minor bug where you couldn't add more than one variable. Also reconciled the comments and code for lags, and changed the lags structure to "var" and "amount" in place of "name" and "lags". Also, updated the test code to add a second variable.
Edit: there are tons of bugs in this version, which I know, because I've unit-tested it a bit more and fixed them, but copying and pasting is very time-consuming, so I will update this post in a few days, once my deadline is over.
Maybe you're looking for this:
fastlinpred <- function(formula, newdata, coefs) {
X <- model.matrix( formula, data=newdata)
X %*% coefs
}
coefs <- c(1,2,3)
dd <- data.frame( temperature = 10, time = 4 )
fastlinpred( ~ temperature + time,
dd , coefs )
This assumes that the formula has only a RHS (you can get rid of the LHS of a formula by doing form[-2]).
This certainly gets rid of a lot of the overhead of predict.lm, but I don't know if it is as fast as you want. model.matrix has a lot of internal machinery too.