# FastSUR algorithm as introduced and described in # Hubert, Verdonck, Yorulmaz (2015), # Fast robust SUR with economical and actuarial applications, # submitted. # Preprint available at wis.kuleuven.be/stat/robust library(rrcov) library(robustbase) library(systemfit) library(plm) library(Matrix) library(clusterGeneration) #rm(list=ls()) fastSUR <- function(Y, X, nsamp=500, bdp=.5) { # fast S algorithm for SUR! #--------------------------------------------------------------------- randomset <- function(tot,nel) { ranset <- rep(0,nel) for (j in 1:nel) { num <- ceiling(runif(1)*tot) if (j > 1) { while (any(ranset==num)) num <- ceiling(runif(1)*tot) } ranset[j] <- num } return(ranset) } # -------------------------------------------------------------------- rhobiweight <- function(x,c) { # Computes Tukey's biweight rho function with constant c for all values in x hulp <- x^2/2 - x^4/(2*c^2) + x^6/(6*c^4) rho <- hulp*(abs(x)=c) return(rho) } # -------------------------------------------------------------------- psibiweight <- function(x,c) { # Computes Tukey's biweight psi function with constant c for all values in x hulp <- x - 2*x^3/(c^2) + x^5/(c^4) psi <- hulp*(abs(x) eps) & (iter < 100)) { c1.old <- c1 fc <- erho.bw(p, c1) - (c1^2 * r)/6 fcp <- erho.bw.p(p, c1) - (c1 * r)/3 c1 <- c1 - fc/fcp if(c1 < 0) c1 <- c1.old/2 crit <- abs(fc) iter <- iter + 1 } return(c1) } "erho.bw" <- function(p, c1) return(chi.int(p, # expectation of rho(d) under chi-squared p 2, c1)/2 - chi.int(p, 4, c1)/(2 * c1^2) + chi.int(p, 6, c1)/(6 * c1^4) + ( c1^2 * chi.int2(p, 0, c1))/6) "erho.bw.p" <- function(p, c1) return(chi.int.p(p, # derivative of erho.bw wrt c1 2, c1)/2 - chi.int.p(p, 4, c1)/(2 * c1^2) + (2 * chi.int(p, 4, c1))/(2 * c1^3) + chi.int.p(p, 6, c1)/(6 * c1^4) - (4 * chi.int(p, 6, c1))/( 6 * c1^5) + (c1^2 * chi.int2.p(p, 0, c1))/6 + (2 * c1 * chi.int2(p, 0, c1))/6) #--------------------------------------------------------------------------# # end 'constant determining' # #--------------------------------------------------------------------------# IRLSstep <- function(Y, X, Xtilde, Beta, Gamma, scale, psres, k, c, b) { convTol <- 1e-10 n <- nrow(Y) m <- ncol(Y) p <- ncol(X) Xl <- X X <- bdiag(Xl[,,1]) for (j in (2:m)){ X <- bdiag(X,Xl[,,j]) } #X <- as.matrix(X) Yvec=vecop(Y) #psres <- sqrt(mahalanobis(Res, rep(0,m), Gamma)) #if (initialscale > 0) # scale <- initialscale #else # scale <- median(psres)/.6745 iter <- 0 betadiff <- 1 while ( (betadiff > convTol) & (iter < k) ) { iter <- iter + 1 newscale <- sqrt(scale^2 * mean(rhobiweight(psres/scale,c))/b) w <- scaledpsibiweight(psres/newscale,c) D <- diag(w) W <- (newscale^(-2)*solve(Gamma))%x%D newBeta <- solve(t(X)%*%W%*%X)%*%t(X)%*%W%*%Yvec vu=vfunction(psres/newscale,c,b) BB=reconvec(newBeta,m) B=bdiag(BB[,1]) for (j in (2:m)){ B=bdiag(B,BB[,j]) } Resfull <- (Y-Xtilde%*%B) Resfull <- as.matrix(Resfull) B <- as.matrix(B) newSigma=m*t(Resfull)%*%D%*%(Resfull)/sum(vu) #newSigma <- t(Resfull)%*%D%*%Resfull newGamma <- det(newSigma)^(-1/m)*newSigma betadiff <- sum((newBeta-Beta)^2)/sum(Beta^2) # use 'sum' as a kind of norm psresnew <- sqrt(mahalanobis(Resfull, rep(0,m), newGamma)) ### scale <- newscale Gamma <- newGamma Sigma <- newSigma Beta <- newBeta psres <- psresnew ### } return(list( Beta = newBeta, Gamma = newGamma, scale = newscale, psres=psresnew,weight=w )) } #-------------------------------------------------------------------------- scale1 <- function(u, b, c, initialsc) { # from Kristel's fastSreg if (initialsc==0) initialsc = median(abs(u))/.6745 maxit <- 100 sc <- initialsc i <- 0 eps <- 1e-10 err <- 1 while (( i < maxit ) & (err > eps)) { sc2 <- sqrt( sc^2 * mean(rhobiweight(u/sc,c)) / b) err <- abs(sc2/sc - 1) sc <- sc2 i <- i+1 } return(sc) } # -------------------------------------------------------------------- # - main function - # -------------------------------------------------------------------- set.seed(10) n <- nrow(Y) m <- ncol(Y) p <- ncol(X) Xtilde=X[,,1] for (j in 2:m){ Xtilde=cbind(Xtilde,X[,,j]) } if (n<=p) stop("number of observations too small (should have n > p)") loop <- 1 c0 <- csolve.bw.asymp(m,bdp) b <- erho.bw(m, c0) bestr <- 5; # number of best solutions to keep for further C-steps k <- 3; # number of C-steps on elemental starts bestbetas <- matrix(0, m*p, bestr) bestpsres <- matrix(0, n, bestr) bestgammas <- matrix(0, m*m, bestr) bestscales <- 1e20 * rep(1,bestr) sworst <- 1e20 while (loop <= nsamp) { detcov <- 0 itertest <- 0 detSj <- 0 while ((detSj<1e-3) && (itertest<500)) { ranset <- randomset(n,p) Yj <- Y[ranset,] Xtildej <- Xtilde[ranset, ] Xlj <- X[ranset, , ] Yjvec <- vecop(Yj) Xj <- bdiag(Xlj[,,1]) for (j in (2:m)){ Xj=bdiag(Xj,Xlj[,,j]) } Xj <- as.matrix(Xj) lsreg <- lm(Yjvec~Xj-1) Bj <- lsreg$coefficients #resvec=lsreg$residuals #res=reconvec(resvec,m) BB <- reconvec(Bj,m) B <- bdiag(BB[,1]) for (j in (2:m)){ B <- bdiag(B,BB[,j]) } resfull <- Y-Xtilde%*%B resfull<-as.matrix(resfull) mads <- apply(resfull, 2, mad) S0 <- diag(mads^2) dist <- sqrt(mahalanobis(resfull,rep(0,m),S0)) w <- scaledpsibiweight(dist,c0) D <- diag(w) Sj <- t(resfull)%*%D%*%resfull/n detSj <- det(Sj) itertest <- itertest+1 } if (itertest==500) stop("too many degenerate subsamples") Gj <- det(Sj)^(-1/m)*Sj psres <- sqrt(mahalanobis(resfull, rep(0,m), Gj)) scale <- median(psres)/.6745 # perform k steps of IRLS on elemental start result <- IRLSstep(Y, X, Xtilde, Bj, Gj, scale, psres, k, c0, b) Betarw <- result$Beta Gammarw <- result$Gamma scalerw <- result$scale psresrw <- result$psres if (loop > 1) { if (mean(rhobiweight(psresrw/sworst,c0)) < b) { ss <- sort(bestscales, index.return=T) ind <- ss$ix[bestr] bestscales[ind] <- scale1(psresrw, b, c0, scalerw) bestbetas[,ind] <- Betarw[,1] bestpsres[,ind] <- psresrw bestgammas[,ind] <- vecop(Gammarw) sworst <- max(bestscales) } } else { bestscales[bestr] <- scale1(psresrw, b, c0, scalerw) bestbetas[,bestr] <- Betarw[,1] bestpsres[,bestr] <- psresrw bestgammas[,bestr] <- vecop(Gammarw) } loop <- loop + 1 } ibest <- which.min(bestscales) superbestscale <- bestscales[ibest] superbestbeta <- reconvec(bestbetas[,ibest],m) superbestgamma <- reconvec(bestgammas[,ibest],m) superbestpsres <- bestpsres[,ibest] # perform C-steps on best 'bestr' solutions, until convergence (or maximum 50 steps) for (i in bestr:1) { tmp <- IRLSstep(Y, X, Xtilde, bestbetas[,i], reconvec(bestgammas[,i],m), bestscales[i],bestpsres[,i], 50, c0, b) if (tmp$scale < superbestscale) { superbestscale <- tmp$scale superbestbeta <- tmp$Beta superbestgamma <- tmp$Gamma superbestweight <- tmp$weight } } superbestbeta <- reconvec(superbestbeta,m) superbestSigma <- superbestscale^2*superbestgamma return(list(Beta=superbestbeta, Gamma=superbestgamma, scale=superbestscale, weight=superbestweight, Sigma=superbestSigma)) }