.packageName <- "SpatialNP"
`RCov` <-
function(X,na.action=na.fail)
{
X <- na.action(X)
if (!all(sapply(X, is.numeric))) stop("'X' must be numeric")
X<-as.matrix(X)

R<-as.matrix(ranks(X))
t(R)%*%R/dim(R)[1]
}

`SCov` <-
function(X,location,na.action=na.fail)
{
X <- na.action(X)
if (!all(sapply(X, is.numeric))) stop("'X' must be numeric")
X<-as.matrix(X)

if(missing(location)) location<-colMeans(X)
n<-dim(X)[1]
if (dim(X)[2]<2) return(diag(1))
sumsignout(sweep(X,2,location))/n
}

`SRCov` <-
function(X,location, na.action=na.fail)
{
X <- na.action(X)
if (!all(sapply(X, is.numeric))) stop("'X' must be numeric")
X<-as.matrix(X)

if(missing(location)) location<-colMeans(X)
R<-as.matrix(signranks(X))
t(R)%*%R/dim(R)[1]
}

`SSCov` <-
function(X,na.action=na.fail)
{
X <- na.action(X)
if (!all(sapply(X, is.numeric))) stop("'X' must be numeric")
X<-as.matrix(X)
if (dim(X)[2]<2) return(diag(1))

tmp<-pairdiff(X)
tmp2<-sumsignout(tmp)/dim(tmp)[1]
tr<-sum(diag(tmp2))
if (tr!=1 & tr!=0)
tmp2<-to.shape(tmp2,trace=1)
tmp2
}

`ae.hl.estimate` <-
function(X,init=NULL,shape=TRUE,maxiter=500,eps=1e-6,na.action=na.fail)
{
 X<-na.action(X)
 if(!all(sapply(X,is.numeric))) stop("'X' must be numeric")
 X<-as.matrix(X)

 p<-dim(X)[2]
 if(p==1) return(median(c(pairsum(X)/2,X)))

 if(is.matrix(shape))
 {
  X<-X%*%solve(mat.sqrt(shape))
  res<-as.vector(mat.sqrt(shape)%*%spatial.median(rbind(pairsum(X)/2,X)))
  attr(res,"shape")<-shape
  return(res)
 }
 else if(is.logical(shape))
 {
  if(!shape) 
  {
   res<-spatial.median(rbind(pairsum(X)/2,X))
   attr(res,"shape")<-diag(p)
   return(res)
  }
 }
 else stop("'shape' must be a matrix or logical")

 if (is.null(init))
  init <- apply(X,2,median)
 else 
  if(any(!is.vector(init),!is.numeric(init)))
   stop("'init' must be a numeric vector or NULL")
  else if (length(init)!=p) stop("'init' is of wrong dimension")
 
 X2<-rbind(X,pairsum(X)/2)
 V0<-signrank.shape(X,init)
 A0<-solve(mat.sqrt(V0))
 differ<-Inf
 iter<-0
 while(differ>eps)
 {
  if (iter==maxiter)
  {
   stop("maxiter reached without convergence")
  }
  theta.k1<-solve(A0)%*%spatial.median(X2%*%t(A0))
  V.k1<-signrank.shape(X,theta.k1)
  A.k1 <- solve(mat.sqrt(V.k1))
  theta.k2<-solve(A.k1)%*%spatial.median(X2%*%t(A.k1))
   V.k2<-signrank.shape(X,theta.k2)
  A0<-solve(mat.sqrt(V.k2))
  differ<-sqrt(sum((theta.k1-theta.k2)^2))
  iter=iter+1
 }
 res<-as.vector(theta.k2)
 attr(res,"shape")<-V.k2
 res
}

`rank.shape` <-
function(X,init=NULL,steps=Inf,eps=1e-6,maxiter=100,na.action=na.fail)
{
 X<-na.action(X)
 if(!all(sapply(X, is.numeric))) stop("'X' must be numeric")
 X<-as.matrix(X) 

 p<-dim(X)[2]
 if(p==1) return(diag(1))
 if (is.null(init)) init<-covshape(X)
 else init<-to.shape(init)
 if(is.finite(steps)) maxiter<-Inf

 iter<-0
 V<-init
 while(TRUE)
 {
  if(iter>=steps) return(V)
  if(iter>=maxiter) stop("maxiter reached")
  iter<-iter+1
  sqrtV<-mat.sqrt(V)
  R<-ranks(X%*%solve(sqrtV))
  V.new<-sqrtV%*%(t(R)%*%R)%*%sqrtV
  V.new<-to.shape(V.new)
  if(all(is.infinite(steps),mat.norm(V.new-V)<eps)) return(V.new)
  V<-V.new
 }
}

`signrank.shape` <-
function(X,location=NULL,init=NULL,steps=Inf,eps=1e-6,maxiter=100,na.action=na.fail)
{
 X<-na.action(X)
 if(!all(sapply(X, is.numeric))) stop("'X' must be numeric")
 X<-as.matrix(X) 

 p<-dim(X)[2]
 if(p==1) return(diag(1))
 if(is.null(init)) init<-covshape(X)
 else init<-to.shape(init)
 if(is.finite(steps)) maxiter<-Inf
 if (is.null(location)) location<-apply(X,2,mean)
 X<-sweep(X,2,location)

 iter<-0
 V<-init
 while(TRUE)
 {
  if(iter>=steps) return(V)
  if(iter>=maxiter) stop("maxiter reached")
  iter<-iter+1
  sqrtV<-mat.sqrt(V)
  Q<-signranks(X%*%solve(sqrtV))
  V.new<-sqrtV%*%(t(Q)%*%Q)%*%sqrtV
  V.new<-to.shape(V.new)
  if(all(is.infinite(steps),mat.norm(V.new-V)<eps)) return(V.new)
  V<-V.new
 }
}

srreg.formula.2<-function(formula,data)
{
  m <- match.call(expand.dots = FALSE)
  m$... <- NULL
  m[[1]] <- as.name("model.frame")
  m <- eval.parent(m)
  Terms <- attr(m, "terms")
  grouping <- model.response(m)
  x <- model.matrix(Terms, m)
  res<-list(Y=grouping,X=x)
  return(res)
} 

srreg.formula<-function(formula,data)
{
m<-model.frame(formula)
X<-model.matrix(formula,m)
#if pieless stop
Y<-model.response(m)
list(Y=Y,X=X)
}


norm<-function(X) 
.C("norming", as.double(X), as.integer(dim(X)), res=double(dim(X)[1]),PACKAGE="ICSNP")$res

pairdiff<-function(X)
{
d<-dim(X)
matrix(.C("pairdiff", as.double(X),as.integer(d), res=double(choose(d[1],2)*d[2]),PACKAGE="ICSNP")$res,ncol=d[2],byrow=T)
}

pairsum<-function(X)
{
d<-dim(X)
matrix(.C("pairsum", as.double(X),as.integer(d), res=double(choose(d[1],2)*d[2]),PACKAGE="ICSNP")$res,ncol=d[2],byrow=T)
}

sumsignout<-function(X)
{
#have to be careful with zero divisions:
ind<-numeric(0)
ind<-apply(X,1,setequal,y=0)
if(length(ind)>0) 
 X<-X[!ind,]

d<-dim(X)
tmp<-matrix(.C("sum_of_sign_outers", as.double(X),as.integer(d), res=double(d[2]^2),PACKAGE="ICSNP")$res,ncol=d[2],byrow=T)
}

ranks<-function(X)
{
d<-dim(X)
if(any(d[2]==1,is.vector(X))) return(rank(X))
tmp<-matrix(.C("spatial_ranks", as.double(X),as.integer(d), res=double(d[1]*d[2]),PACKAGE="ICSNP")$res,ncol=d[2],byrow=T)

#need to check whether multiple values caused a problem:
ind<-which(!is.finite(tmp[,1]))
if(length(ind)==0) return(tmp)
#else the problem ranks need to be recalculated:
for(i in ind) {
 s<-sweep(X,2,X[i,]) 
 r<-norm(s)
 r[r==0]<-1
 tmp[i,]<-apply(sweep(s,1,r,"/"),2,mean)
}
tmp
}

signranks<-function(X)
{
d<-dim(X)
tmp<-matrix(.C("signed_ranks", as.double(X),as.integer(d), res=double(d[1]*d[2]),PACKAGE="ICSNP")$res,ncol=d[2],byrow=T)
#as in ranks, possibly need to recalculate stuff
ind<-which(!is.finite(tmp[,1]))
if(length(ind)==0) return(tmp)
#else 
for(i in ind) {
 sm<-sweep(X,2,X[i,]) 
 sp<-sweep(X,2,X[i,],"+")
 rm<-norm(sm)
 rp<-norm(sp)
 rm[rm==0]<-1
 tmp[i,]<-(apply(sweep(sm,1,rm,"/"),2,mean)+apply(sweep(sp,1,rp,"/"),2,mean))/2
}
tmp
}

Q2internal<-function(X)
{
d<-dim(X)
.C("Q2internals",as.double(X),as.integer(d), res=double(d[2]^2+d[2]^4),PACKAGE="ICSNP")$res
}

gen.inv<-function(M)
{
p<-sqrt(dim(M)[1])
eig<-eigen(M)
attach(eig)
values[1:((p+2)*(p-1)/2)]<-values[1:((p+2)*(p-1)/2)]^-1
res<-vectors%*%diag(values)%*%t(vectors)
detach(eig)
Re(res) #because it really is real!
}

Cpp<-function(p)
{
I<-diag(p)
vecI<-I
dim(vecI)<-NULL
J<-vecI%*%t(vecI)
K<-matrix(0,ncol=p^2,nrow=p^2)
for (i in 1:p) for (j in 1:p) K<-K+kronecker(outer(I[,i],I[,j]),outer(I[,j],I[,i]))
(diag(p^2)+K)/2-J/p
}

covshape<-function(x) to.shape(cov(x))

mat.sqrt<-function(A)
# Returns the square root matrix of the given matrix.
{
 eig<-eigen(A)
 eig$vectors%*%(diag(eig$values))^(1/2)%*%t(eig$vectors)
}

mat.norm<-function(A)
# Returns the matrix norm of the given matrix.
{
 sqrt(sum(diag(t(A)%*%A)))
}
`spatial.location` <-
function(X,score=c("sign","signrank"),init=NULL,shape=TRUE,maxiter=500,eps=1e-6,na.action=na.fail)
{
 score<-match.arg(score)
 switch(score,
       "sign"=
       {
        if(is.matrix(shape))
        {
         res<-spatial.median(X%*%solve(mat.sqrt(shape)),init, maxiter,eps,na.action=na.action)
         attr(res,"shape")<-shape
         res
        }
        else if(is.logical(shape))
        {
         if(shape) 
         {
          res1<-HR.Mest(X,maxiter,eps,eps,na.action)
          res<-res1$center
          attr(res,"shape")<-res1$scatter

         }
         else 
         {
          res<-spatial.median(X,init,maxiter,eps,na.action=na.action)
          attr(res,"shape")<-diag(dim(X)[2])
         }
        }
        else stop("'shape' must be a matrix or logical")
       },
       "signrank"=
       ae.hl.estimate(X,init,shape,maxiter,eps,na.action=na.fail)
       )
}

`spatial.rank` <-
function(X,shape=TRUE,na.action=na.fail,...)
    {     
    X<-na.action(X)
    if(!all(sapply(X, is.numeric))) stop("'X' must be numeric") 
    X<-as.matrix(X)   

    p <- dim(X)[2]
  
    if(is.numeric(shape) & p!=1) if(!all(dim(shape)==c(p,p))) stop("'shape' is of wrong dimension")

    if (!is.numeric(shape)) {
     if(shape) shape<-rank.shape(X,...)
     else shape<-diag(p)
    }
    spatial.ranks<-ranks(X%*%mat.sqrt(solve(shape)))
    attr(spatial.ranks,"shape")<-shape
    return(spatial.ranks)
}

`spatial.shape` <-
function(X, score = c("sign", "symmsign", "rank", "signrank"),
location = NULL, init = NULL, steps = Inf, eps = 1e-06, maxiter = 100,
na.action = na.fail)
{
score<-match.arg(score)
switch(score,
       "sign"=tyler.shape(X,location, init, steps, eps, maxiter, na.action=na.action),
       "symmsign"=duembgen.shape(X, init, steps, eps, maxiter, na.action=na.action),
       "rank"=rank.shape(X, init, steps, eps, maxiter, na.action),
       "signrank"=signrank.shape(X, location, init, steps, eps, maxiter, na.action))
}

`spatial.signrank` <-
function(X,center=TRUE,shape=TRUE,na.action=na.fail,...)
    {     
    X<-na.action(X)
    if(!all(sapply(X, is.numeric))) stop("'X' must be numeric") 
    X<-as.matrix(X)   

    p <- dim(X)[2]

    if(is.numeric(center)) if(length(center)!=p) stop("'center' is of wrong dimension")
    if(is.numeric(shape) & p!=1) if(!all(dim(shape)==c(p,p))) stop("'shape' is of wrong dimension")

    if(!all(is.numeric(center),is.numeric(shape)))
    # unless already given:
    {
     if(is.numeric(center))
     # shape needs to be set:
      if (shape) shape<-signrank.shape(X,location=center,...)
      else shape<-diag(p)

     else if(is.numeric(shape))
     # center needs to be set:
      if (center) {
       center<-mat.sqrt(shape)%*%ae.hl.estimate(X,shape=shape,...)
       attr(center,"shape")<-NULL
      }
      else center<-rep(0,p)
 
     else 
     # both need to be set:
      if (all(shape,center)) 
      # both need to be estimated
      {
       center<-ae.hl.estimate(X,...)
       shape<-attr(center,"shape")
       attr(center,"shape")<-NULL
      }
      else if(shape)
      {
       center<-rep(0,p)
       shape<-signrank.shape(X,location=FALSE,...)
      }
      else if(center)
      {
       shape<-diag(p)
       center<-ae.hl.estimate(X,ae=F)
       attr(center,"shape")<-NULL
      }
      else
      {
      center<-rep(0,p) 
      shape<-diag(p)
      }
    }


    spatial.signranks<-signranks(X%*%mat.sqrt(solve(shape)))
    attr(spatial.signranks,"center")<-center
    attr(spatial.signranks,"shape")<-shape
    return(spatial.signranks)
}

`spatial.symmsign` <-
function(X,shape=TRUE,na.action=na.fail,...)
    {     
    X<-na.action(X)
    if(!all(sapply(X, is.numeric))) stop("'X' must be numeric") 
    X<-as.matrix(X)   

    p <- dim(X)[2]
  
    if(is.numeric(shape) & p!=1) if(!all(dim(shape)==c(p,p))) stop("'shape' is of wrong dimension")

    spatial.symmsigns<-spatial.sign(pairdiff(X),center=FALSE,shape=shape,...)
    attr(spatial.symmsigns,"center")<-NULL
    return(spatial.symmsigns)
}

`sr.indep.test` <- function(X,Y=NULL,g=NULL,score=c("sign","symmsign","rank"),regexp=FALSE,cond=FALSE,cond.n=1000,na.action=na.fail)
{
 if(all(is.null(Y),is.null(g))) stop("Y or g must be given")

 score=match.arg(score)
 
 if(!is.null(g)) {
  if(is.factor(g)) {
   DNAME<-paste(deparse(substitute(X)),"by",deparse(substitute(g)))
   X<-na.action(X)
   Y<-X[,g==levels(g)[2]]
   X<-X[,g==levels(g)[1]]
  }
  else {
   if(is.character(g)) 
    if (regexp) gn<-grep(g,colnames(X))
    else gn<-match(g,colnames(X))
   else gn<-g    # should be is.numeric(g)==TRUE
   gn.char<-paste("c(",paste(g,collapse=","),")",sep="")
   DNAME<-paste(deparse(substitute(X)),"columns",gn.char,"vs. the rest")
   X<-na.action(X)
   Y<-X[,-gn]
   X<-X[,gn]
  }
 }
 else
  {
   DNAME<-paste(deparse(substitute(X)),"and",deparse(substitute(Y)))
   X<-na.action(X)
   if(!is.null(attr(X,"na.action"))) Y<-Y[-(attr(X,"na.action")),]
   Y<-na.action(Y)
   if(!is.null(attr(Y,"na.action"))) X<-X[-(attr(Y,"na.action")),]
  }      

 X<-as.matrix(X)
 Y<-as.matrix(Y) 
 p1<-dim(X)[2]
 p2<-dim(Y)[2]

 n<-dim(X)[1]
 if(dim(Y)[1]!=n) stop("the number of observations in the data sets differ")
 STATISTIC<-switch(score,
	"sign"=
	{
         METHOD<-"Multivariate independence test using spatial signs"
	 SX<-spatial.sign(X,center=T,shape=T)
	 SY<-spatial.sign(Y,center=T,shape=T)
	 ave<-t(SX)%*%SY/n
	 n*p1*p2*mat.norm(ave)^2
	},
	"symmsign"=
	{
         METHOD<-"Multivariate independence test using spatial symmetrized signs"
	 SX<-spatial.sign(pairdiff(X),center=F,shape=T)
	 SY<-spatial.sign(pairdiff(Y),center=F,shape=T)
	 # there are now n*(n-1)/2 rows in these matrices
	 m<-choose(n,2)
	 RX<-spatial.rank(X,shape=T)
	 RY<-spatial.rank(Y,shape=T)
	 cx1<-mean(norm(RX)^2)
	 cx2<-mean(norm(RY)^2)
	 ave<-t(SX)%*%SY/m
	 ((n*p1*p2)/(4*cx1*cx2))*mat.norm(ave)^2
	},
	"rank"=
	{
         METHOD<-"Multivariate independence test using spatial ranks"
	 RX<-spatial.rank(X,shape=T)
	 RY<-spatial.rank(Y,shape=T)
	 ave<-t(RX)%*%RY/n
	 if (p1==1) cx1<-1/3 
	  else cx1<-mean(norm(RX)^2)
	 if (p2==1) cx2<-1/3
	  else cx2<-mean(norm(RY)^2)
	 ((n*p1*p2)/(cx1*cx2))*mat.norm(ave)^2
	})
 names(STATISTIC)<-"Q.2"

 if (cond)
 {
  PARAMETER<-cond.n
  names(PARAMETER)<-"replications"
  statg<-NULL
  for (j in 1:cond.n)
  {
   statg<-c(statg,switch(score,
	"sign"=
	{
	 perm<-sample(n)
	 ave<-t(SX)%*%SY[perm,]/n
   	 n*p1*p2*mat.norm(ave)^2
	},
	"symmsign"=
	{
	 perm<-sample(m)
	 ave<-t(SX)%*%SY[perm,]/m
   	 ((n*p1*p2)/(4*cx1*cx2))*mat.norm(ave)^2
	},
	"rank"=
	{
	 perm<-sample(n)
	 ave<-t(RX)%*%RY[perm,]/n
	 ((n*p1*p2)/(cx1*cx2))*mat.norm(ave)^2
	}))
  }
  PVAL<-mean(statg>=STATISTIC)
 }
 else
 {
  df<-p1*p2
  PARAMETER<-df
  names(PARAMETER)<-"df"
  PVAL<-1-pchisq(STATISTIC,df)
 }
 ALTERNATIVE<-"two.sided"
 NVAL<-0
 names(NVAL)<-"measure of dependence"
 res<-list(statistic=STATISTIC,parameter=PARAMETER,null.value=NVAL,alternative=ALTERNATIVE,method=METHOD,data.name=DNAME,p.value=PVAL)
 class(res)<-"htest"
 res
}

`sr.loc.test` <-
function(X,Y=NULL,g=NULL,score=c("sign","rank"),nullvalue=NULL,cond=FALSE,cond.n=1000,na.action=na.fail,...) 
{
 if (all(is.null(Y),is.null(g))) { #there is only X
  DNAME<-deparse(substitute(X))
  X<-na.action(X)
  X<-as.matrix(X)
  g<-as.factor(rep(1,dim(X)[1]))
 }
 else if(!is.null(Y)) {            #there are X and Y
  if(dim(X)[2]!=dim(Y)[2]) stop("X and Y must have the same number of columns")
  DNAME<-paste(deparse(substitute(X)),"and",deparse(substitute(Y)))
  X<-na.action(X)
  Y<-na.action(Y)
  g<-factor(c(rep(1,dim(X)[1]),rep(2,dim(Y)[1])))
  X<-as.matrix(X)
  Y<-as.matrix(Y)
  X<-rbind(X,Y)
 }
 else if(!is.factor(g))            #there is a g but it's not a factor
  stop("g must be a factor or NULL")
 else {                            #there are X and g
  DNAME<-paste(deparse(substitute(X)),"by",deparse(substitute(g)))
  X<-as.matrix(X)
  Xandg<-cbind(g,X)
  Xandg<-na.action(Xandg)
  g<-factor(Xandg[,1])
  X<-as.matrix(Xandg[,-1])
  rm(Xandg)
 }

 n<-dim(X)[1]
 p<-dim(X)[2]
 c<-nlevels(g)
 if(!is.null(nullvalue)) {
  if(length(nullvalue)!=p) 
   stop("'nullvalue' must have length equal to the number of columns of 'X'")
 }
 else nullvalue<-rep(0,p)
 X<-sweep(X,2,nullvalue)
 NVAL<-paste("c(",paste(nullvalue,collapse=","),")",sep="")
 if(c==1) names(NVAL)<-"location" 
  else if(c==2) names(NVAL)<-"difference between group locations"
  else names(NVAL)<-"difference between some group locations"

 score=match.arg(score)

 switch(score,
     "sign"=
     {
      if (c==1)
      {
       METHOD<-"One sample location test using spatial signs"
       scoremat<-spatial.sign(X,center=F)
      }
      else
      {
       METHOD<-"Several samples location test using spatial signs"
       scoremat<-spatial.sign(X)
      }
     },
     "rank"=
     {
      if (c==1) 
      {
       METHOD<-"One sample location test using spatial signed ranks"
       if (p>1) V<-signrank.shape(X)
      }
      else 
      {
       METHOD<-"Several samples location test using spatial ranks"
       if (p>1) V<-rank.shape(X)
      }
      if (p==1) V<-diag(1)
      scoremat<-spatial.rank(X%*%solve(mat.sqrt(V)),shape=FALSE)
      c2<-mean(norm(scoremat)^2)
     })
 
 if (c==1) {
  STATISTIC<-switch(score,
     "sign"=
     { 
      n*p*sum(apply(scoremat,2,mean)^2)
     },
     "rank"=
     {
      sums<-pairsum(X)%*%mat.sqrt(solve(V))
      ave<-apply(spatial.sign(sums,center=F,shape=F),2,mean)
      rm(sums)
      n*p*sum(ave^2)/(4*c2)
     })
 } # end c==1
 else { # c != 1
  bar<-numeric(0)
  sizes<-numeric(0)
  for (i in 1:c) {
   bar<-rbind(bar,apply(scoremat[g==levels(g)[i],,drop=F],2,mean))
   sizes<-c(sizes,sum(g==levels(g)[i]))
  }
  STATISTIC<-p*sum(sizes*(norm(bar)^2))/switch(score,"sign"=1,"rank"=c2)
 }

 if (all(cond,score=="sign"))
 {
  Qd<-numeric(0)
  if(c==1) {
   for (i in 1:cond.n) {
    d<-matrix(sample(c(-1,1),n*p,replace=T),nrow=n)
    Qd<-c(Qd,n*p*sum(apply(scoremat*d,2,mean)^2))
   }
  }
  else {
   for (i in 1:cond.n) {
    gd<-sample(g)
    bar<-numeric(0)
    for (j in 1:c)
     bar<-rbind(bar,apply(scoremat[gd==levels(gd)[i],,drop=F],2,mean))
    Qd<-c(Qd,p*sum(sizes*(norm(bar)^2)))
   }
  }
  PARAMETER<-cond.n
  names(PARAMETER)<-"replications"
  PVAL<-mean(Qd>=STATISTIC)
 }
 else  
 {  
  PVAL<-1-pchisq(STATISTIC,(df<-p*max(1,c-1)))
  PARAMETER<-df
  names(PARAMETER)<-"df"
 }
 ALTERNATIVE<-"two.sided"
 names(STATISTIC)<-"Q.2"
 res<-c(list(statistic=STATISTIC,parameter=PARAMETER,p.value=PVAL,null.value=NVAL,alternative=ALTERNATIVE,method=METHOD,data.name=DNAME))
 class(res)<-"htest"
 return(res)
}

sr.regression<- function(formula,data=NULL,score=c("sign","rank"),ae=TRUE,eps=1E-6,na.action=na.fail)
{
  score<-match.arg(score)

  mydata<-srreg.formula(formula,data)
  mydata$X<-na.action(mydata$X)
  if(is.vector(mydata$Y)) mydata$Y<-as.matrix(mydata$Y)
  if(!is.null(foo<-attr(mydata$X,"na.action"))) mydata$Y<-mydata$Y[-foo,]
  mydata$Y<-na.action(mydata$Y)
  if(!is.null(foo<-attr(mydata$Y,"na.action"))) mydata$X<-mydata$X[-foo,]


  if(score=="rank")
# Recursive! Regression based on ranks is in fact
# regression based on signs of the pairwise differences
  {
   int=FALSE
   if( length(i<-which(attr(mydata$X,"assign")==0)) > 0 ) {
    int=TRUE
   if(length(i) == dim(mydata$X)[2]) {
    temp<-rbind(ae.hl.estimate(mydata$Y,shape=TRUE,eps=eps))
    rownames(temp)<-c("(Intercept)")
    return(temp)
   }
   Xd<-pairdiff(mydata$X[,-i])
   }
   else Xd<-pairdiff(mydata$X)
   Yd <- pairdiff(mydata$Y)
  
   difdata <- data.frame(Y=Yd,X=Xd)
  
   B <- sr.regression(Yd~Xd-1,difdata,score="sign",ae,eps)

   # possibly compute the intercept #
   if(int) {
   Ehat <- mydata$Y - mydata$X[,-1] %*% B
   b0 <- ae.hl.estimate(Ehat,shape=TRUE,eps=eps)
   }
   else b0 <- rep(NA,dim(mydata$Y)[2])
  
   temp<-rbind(b0,B)
   if(int) rownames(temp)<-colnames(mydata$X)
   else rownames(temp)<-c("(Intercept)", colnames(mydata$X))
   return(temp)
  } #end rank based
  
  X <- matrix(mydata$X,nrow=nrow(mydata$X))
  Y <- matrix(mydata$Y,nrow=nrow(mydata$Y))
  
  n<-dim(X)[1]
  p<-dim(X)[2]
  d<-dim(Y)[2]

  if(d==1) ae=FALSE

  # Preliminary estimate/starting value #
  B.new <- solve(t(X)%*%X)%*%t(X)%*%Y

  if (ae==TRUE)
  {
    # estimate residuals by a preliminary estimate #
    Ehat <- Y - X %*% B.new
    V <- tyler.shape(Ehat)
    sqrt.V <- mat.sqrt(V)
    Y <- t(solve(sqrt.V) %*% t(Y))
    B.new <- solve(t(X)%*%X)%*%t(X)%*%Y
  }
  
  B <- matrix(c(rep(0,p*d)),nrow=p,ncol=d)
    
  while (sum((B-B.new)**2)>eps)
  {
    B <- B.new
    
    # estimated residuals #
    Ehat <- Y - X %*% B
  
    # Euclidian norms of the residuals #
    r <- norm(Ehat)
    
    # investigate if there are at least p+1 zero residuals, and if so, #
    # investigate the value of the objective function to see if this   #
    # is the solution #
    if (max(sort(r)[1:(p+1)])<eps)
    {
      index<-(1:n)[r>eps]
      if (sum(apply(Ehat[index,]/r[index],2,sum)**2)>min(1E-6,eps)) 
        B.new <- solve(t(X/(cbind(r)%*%rep(1,p)))%*%X)%*%(t(X)%*%(Y/(cbind(r)%*%rep(1,d))))
    } 
    else
      B.new <- solve(t(X/(cbind(r)%*%rep(1,p)))%*%X)%*%(t(X)%*%(Y/(cbind(r)%*%rep(1,d))))
  }

  # Transform back if one-step T-R procedure is used #
   if (ae==TRUE) B.new <- t(sqrt.V %*% t(B.new))

  rownames(B.new)<-colnames(mydata$X)
  B.new
}
`sr.sphere.test` <-
function(X,score=c("sign","symmsign"),shape=NULL, na.action=na.fail)
{
 DNAME=deparse(substitute(X))
 X<-na.action(X)
 if(!all(sapply(X, is.numeric))) stop("'X' must be numeric") 

 score=match.arg(score)
 X<-as.matrix(X)

 p<-dim(X)[2]
 if (p<2) stop("'X' must be at least bivariate")
 n<-dim(X)[1]
 
 if(!is.null(shape))
 {
  if(!is.matrix(shape)) stop("'shape' must be a matrix")
  if(!all(dim(shape)==c(p,p))) stop("dimensions of 'shape' and 'X' do not match")
  X<-X%*%solve(mat.sqrt(shape))
 }

 Cp<-Cpp(p)

 STATISTIC<-switch(score,
  "sign"=
  {
   METHOD="Test of sphericity using spatial signs" 
   S<-spatial.sign(X,F,F)
   S1<-as.vector(t(S)%*%S/n)
   Q1<-(sum((Cp%*%S1)^2))
   gamma<-2/(p*(p+2))
   n*Q1/gamma
  },
  "symmsign"=
  {
   METHOD="Test of sphericity using spatial symmetrized signs" 
   tmp<-Q2internal(X)
   S2<-tmp[1:p^2]
   covmat<-4*(matrix(tmp[-(1:p^2)],ncol=p^2)-S2%*%t(S2))/n
   as.vector(t(Cp%*%S2)%*%gen.inv(covmat)%*%(Cp%*%S2))
  })
 names(STATISTIC)<-"Q.2"
 NVAL<-paste("diag(",paste(p),")",sep="")
 names(NVAL)<-"shape"
 PVAL<-1-pchisq(STATISTIC,(df<-(p+2)*(p-1)/2))
 PARAMETER<-df
 names(PARAMETER)<-"df"
 ALTERNATIVE<-"two.sided"
 res<-list(statistic=STATISTIC,parameter=PARAMETER,p.value=PVAL,null.value=NVAL,alternative=ALTERNATIVE,method=METHOD,data.name=DNAME)
 class(res)<-"htest"
 res
}

to.shape<-function(M,determ,trace,first)
{
 if(all(missing(determ),missing(trace),missing(first))) 
  return(M/det(M)^(1/dim(M)[2]))
 if(!missing(determ))
  return(M*(determ/det(M))^(1/dim(M)[2]))
 if(!missing(trace))
  return(M*trace/sum(diag(M)))
 M/M[1,1]
}
