addnode<-function(inde,curre,curdep,left,right,parent,low,upp,N,numnode){
#(inde,curre,curdep,left,right,deplink,low,upp,enofatdep,N,numnode){
#
#inde is d-vector: index (gridpoint) to be added
#curre is pointer to vectors left,right,...
#
d<-length(inde)
apu<-depth2com(curdep,N)
curdir<-apu$direc
depatd<-apu$depind
depit<-log(N,base=2)
#depit[d]<-depit[d]+1
#
while (curdir<=(d-1)){
    ind<-inde[curdir]
    while (depatd<=depit[curdir]){
        mid<-(low[curre]+upp[curre])/2
        if (ind<=mid){
           left[curre]<-numnode+1
           parent[numnode+1]<-curre
           low[numnode+1]<-low[curre]
           upp[numnode+1]<-floor(mid)
        }
        else{
           right[curre]<-numnode+1
           parent[numnode+1]<-curre
           low[numnode+1]<-ceiling(mid)
           upp[numnode+1]<-upp[curre]
        }
        numnode<-numnode+1
        curre<-numnode
        depatd<-depatd+1
        curdep<-curdep+1
#        deplink[endofatdep[curdep]]<-numnode
#        deplink[numnode]<-0
#        endofatdep[curdep]<-numnode
    }
    #
    # Last node of this dimension (first node of next dimension)
    #
    curdir<-curdir+1
    ind<-inde[curdir]
    low[curre]<-1
    upp[curre]<-N[curdir]
    mid<-(low[curre]+upp[curre])/2
    if (ind<=mid){
           left[curre]<-numnode+1
           parent[numnode+1]<-curre
           low[numnode+1]<-low[curre]
           upp[numnode+1]<-floor(mid)
    }
    else{
           right[curre]<-numnode+1
           parent[numnode+1]<-curre
           low[numnode+1]<-ceiling(mid)
           upp[numnode+1]<-upp[curre]
    }
    depatd<-2
    numnode<-numnode+1
    curre<-numnode
    curdep<-curdep+1
#    deplink[endofatdep[curdep]]<-numnode
#    deplink[curre]<-0
#    endofatdep[curdep]<-numnode
}
#
# Last dimension 
#
ind<-inde[curdir]
while (depatd<=depit[curdir]){
        mid<-(low[curre]+upp[curre])/2
        if (ind<=mid){
           left[curre]<-numnode+1
           parent[numnode+1]<-curre
           low[numnode+1]<-low[curre]
           upp[numnode+1]<-floor(mid)
        }
        else{
           right[curre]<-numnode+1
           parent[numnode+1]<-curre
           low[numnode+1]<-ceiling(mid)
           upp[numnode+1]<-upp[curre]
        }
        numnode<-numnode+1
        curre<-numnode
        depatd<-depatd+1
        curdep<-curdep+1
#        deplink[endofatdep[curdep]]<-numnode
#        deplink[curre]<-0
#        endofatdep[curdep]<-numnode
}
#
# Last node of last dimension
#
#left[curre]<-0
#right[curre]<-0
#
#return(list(numnode=numnode,left=left,right=right,deplink=deplink,low=low,
#upp=upp,endofatdep=endofatdep))
return(list(numnode=numnode,left=left,right=right,parent=parent,low=low,
upp=upp,nodeloc=numnode))
}










allokoi.new<-function(cur,vecs,lst,left,right,sibord)
{
# allocates space for all children of "cur"

# Calculate the number of childs and sum of volumes of childs
now<-left[cur]
childnum<-1
childvolume<-lst$volume[now]
while (right[now]>0){
  now<-right[now]
  childnum<-childnum+1
  childvolume<-childvolume+lst$volume[now]
}
 
gaplen<-(lst$volume[cur]-childvolume)/(childnum+1)

if (childnum==1){
   now<-left[cur]
   xbeg<-gaplen+vecs[cur,1]
   xend<-xbeg+lst$volume[now]
   ycoo<-lst$level[now]
   vecs[now,]<-c(xbeg,xend,ycoo)
}
else{
  siblinks<-matrix(0,childnum,1)  #make siblinks in right order
  now<-left[cur] 
  sior<-sibord[now]
  siblinks[sior]<-now
  while (right[now]>0){
    now<-right[now]
    sior<-sibord[now]
    siblinks[sior]<-now
  }
  xend<-vecs[cur,1]      #initialize xend 
  for (i in 1:childnum){
     now<-siblinks[i]
     xbeg<-gaplen+xend
     xend<-xbeg+lst$volume[now]
     ycoo<-lst$level[now]
     vecs[now,]<-c(xbeg,xend,ycoo)
  }
} 


return(vecs)
}


allokoi<-function(vecs,cur,child,sibling,sibord,levels,volumes)
{
#Finds coordinates of a node
#sibord,levels,volumes are nodenum-vector

# Calculate the number of childs and sum of volumes of childs
now<-child[cur]
childnum<-1
childvolume<-volumes[now]
while (sibling[now]>0){
  now<-sibling[now]
  childnum<-childnum+1
  childvolume<-childvolume+volumes[now]
}
 
gaplen<-(volumes[cur]-childvolume)/(childnum+1)

if (childnum==1){
   now<-child[cur]
   xbeg<-gaplen+vecs[cur,1]
   xend<-xbeg+volumes[now]
   ycoo<-levels[now]
   vecs[now,]<-c(xbeg,ycoo,xend,ycoo)
}
else{
  siblinks<-matrix(0,childnum,1)  #make siblinks in right order
  now<-child[cur] 
  sior<-sibord[now]
  siblinks[sior]<-now
  while (sibling[now]>0){
    now<-sibling[now]
    sior<-sibord[now]
    siblinks[sior]<-now
  }
  xend<-vecs[cur,1]      #initialize xend 
  for (i in 1:childnum){
     now<-siblinks[i]
     xbeg<-gaplen+xend
     xend<-xbeg+volumes[now]
     ycoo<-levels[now]
     vecs[now,]<-c(xbeg,ycoo,xend,ycoo)
  }
} 
return(vecs)
}



alloroot<-function(vecs,roots,sibord,levels,volumes)
{
rootnum<-length(roots)

# Calculate sum of volumes of roots
rootsvolume<-0
for (i in 1:rootnum){
  now<-roots[i]
  rootsvolume<-rootsvolume+volumes[now]
}

basis<-rootsvolume+rootsvolume/4
 
gaplen<-(basis-rootsvolume)/(rootnum+1)

rootlinks<-matrix(0,rootnum,1)  #make links in right order

if (rootnum==1) rootlinks[1]<-1
else{
for (i in 1:rootnum){
  now<-roots[i]
  roor<-sibord[now]
  rootlinks[roor]<-now
}
}
xbeg<-0
xend<-0
for (i in 1:rootnum){
  now<-rootlinks[i]
  xbeg<-gaplen+xend
  xend<-xbeg+volumes[now]
  ycoo<-levels[now]
  vecs[now,]<-c(xbeg,ycoo,xend,ycoo)
}
return(vecs)
}
blokitus2<-function(obj,blokki){
#
sar<-length(obj[1,]) #sarakkeiden maara 
riv<-length(obj[,1]) #rivien maara 
#
uusobj<-matrix(0,riv,sar+blokki)
uusobj[,1:sar]<-obj
#
return(uusobj)
}
blokitus<-function(obj,blokki){
#
if (dim(t(obj))[1]==1) k<-1 else k<-length(obj[,1]) #rivien maara 
if (k==1){
  len<-length(obj)
  uusobj<-matrix(0,len+blokki,1)
  uusobj[1:len]<-obj
}
else{
  lev<-length(obj[1,])
  uusobj<-matrix(0,k+blokki,lev)
  uusobj[1:k,]<-obj
}
return(uusobj)
}
boundbox<-function(rec1,rec2)
{
# rec:s are 2*d-vectors

d<-length(rec1)/2
rec<-matrix(0,2*d,1)

for (i in 1:d){
    rec[2*i-1]<-min(rec1[2*i-1],rec2[2*i-1])
    rec[2*i]<-max(rec1[2*i],rec2[2*i])
}

return(rec)
}

branchmap<-function(estiseq,hseq=NULL,levnum=80,paletti=NULL,rootpaletti=NULL,
type="jump")
{
#type= "smooth", "jump", "diffe" 

if (is.null(paletti))
 paletti<-c("red","blue","green",
 "orange","navy","darkgreen",
 "orchid","aquamarine","turquoise",
 "pink","violet","magenta","chocolate","cyan",
 colors()[50:100])
if (is.null(rootpaletti)) rootpaletti<-colors()[102:110]

lstseq<-estiseq$lstseq
if (is.null(hseq))
   if (!is.null(estiseq$type)){
       if (estiseq$type=="bagghisto") hseq<--estiseq$hseq
       if (estiseq$type=="carthisto")  hseq<--estiseq$leaf
       if (estiseq$type=="kernel")  hseq<-estiseq$hseq
   }
   else hseq<-estiseq$hseq
hnum<-length(hseq)

if (hseq[1]>hseq[2]){  
    hseq<-hseq[seq(hnum,1)]
    apuseq<-list(lstseq[[hnum]])
    i<-2
    while (i <= hnum){
         apuseq<-c(apuseq,list(lstseq[[hnum-i+1]]))
         i<-i+1 
   }
   lstseq<-apuseq
}

maxlevel<-0
i<-1
while (i<=hnum){
   lst<-lstseq[[i]]
   maxlevel<-max(max(lst$level),maxlevel)
   i<-i+1
}

levstep<-maxlevel/(levnum-1)
level<-seq(0,maxlevel,levstep)
z<-matrix(0,length(level)+1,length(hseq)+1)
#col<-matrix("white",length(level),length(hseq))
colot<-matrix("white",(length(level))*(length(hseq)),1)

i<-1
while (i<=hnum){
    lst<-lstseq[[i]]  #[[hnum-i+1]]

    if ((type=="smooth") || (type=="diffe")){
          eb<-excmas.bylevel(lst,length(level)+1)
          if (type=="smooth")  z[,i]<-eb$levexc
          else z[,i]<-eb$diffe
    }
    mut<-multitree(lst$parent)
    ex<-excmas(lst)
    fb<-findbranch.pare(lst$parent)
    if (is.null(fb)) branchnum<-0 else branchnum<-length(fb)

    if (branchnum==0) toplevel<-max(lst$level) else toplevel<-min(lst$level[fb])
    # toplevel is the level of the next branch
    rootnum<-length(mut$roots)
    rootstep<-toplevel/rootnum
    ordroots<-order(ex[mut$roots])  #order(lst$level[mut$roots])

    exmassa<-0     
    k<-1
    while (k<=rootnum){
        ind<-mut$roots[ordroots[k]]
        exmassa<-exmassa+ex[ind]  
        k<-k+1
    }

    leveka<-1
    levend<-max(leveka,min(round(levnum*toplevel/maxlevel),levnum))
    curleveka<-leveka
    k<-1
    while (k<=rootnum){
        ind<-mut$roots[ordroots[k]]
        curexma<-ex[ind] 
curlevend<-max(curleveka,min(round(curleveka+(levend-leveka)*curexma/exmassa),levend))
        if (type=="jump") z[curleveka:curlevend,i]<-exmassa
        ##col[curleveka:curlevend,i]<-rootpaletti[k]
        aa<-(i-1)*(levnum)+min(curleveka,levnum)
        bb<-(i-1)*(levnum)+min(curlevend,levnum)
        colot[aa:bb]<-rootpaletti[k]
        curleveka<-curlevend+1
        k<-k+1
    }

    curlevel<-toplevel   # curlevel is the level of the previous branching
    ordbranches<-order(lst$level[fb])
    k<-1
    while (k<=branchnum){

        branchind<-ordbranches[k]
        branch<-fb[branchind]

        if (k==branchnum) toplevel<-max(lst$level) 
        else{
            nextbranch<-fb[ordbranches[k+1]]
            toplevel<-lst$level[nextbranch]
        }
        childnum<-2
        children<-c(mut$child[branch],mut$sibling[mut$child[branch]])
        ordchild<-order(ex[children])  #order(lst$level[children])

        exmassa<-0     
        l<-1
        while (l<=childnum){
             ind<-children[ordchild[l]]
             exmassa<-exmassa+ex[ind]  
             l<-l+1
        }

        leveka<-curlevend+1
        levend<-max(leveka,min(leveka+round(levnum*(toplevel-curlevel)/maxlevel),levnum))
        curleveka<-leveka
        l<-1
        while (l<=childnum){
           ind<-children[ordchild[l]]
           curexma<-ex[ind]
  curlevend<-max(curleveka,min(round(curleveka+(levend-leveka)*curexma/exmassa),levend)) 
           if (type=="jump") z[curleveka:curlevend,i]<-exmassa
           ##col[curleveka:curlevend,i]<-paletti[l]
           aa<-(i-1)*(levnum)+min(curleveka,levnum)
           bb<-(i-1)*(levnum)+min(curlevend,levnum)
           colot[aa:bb]<-paletti[l]
           curleveka<-curlevend+1
           l<-l+1
        }
        curlevel<-toplevel
        k<-k+1
    }
    i<-i+1
}

z[,dim(z)[2]]<-z[,dim(z)[2]-1]
z[dim(z)[1],]<-z[dim(z)[1]-1,]
hseq[length(hseq)+1]<-hseq[length(hseq)]+hseq[length(hseq)]-hseq[length(hseq)-1]
level[length(level)+1]<-level[length(level)]+level[length(level)]-level[length(level)-1]

z<-z/max(z)

# add one column to the matrix: a new first column

lisa<-1
zapu<-matrix(0,dim(z)[1],dim(z)[2]+lisa)
zapu[,1:lisa]<-0
zapu[,(lisa+1):(lisa+dim(z)[2])]<-z

yapu<-matrix(0,length(hseq)+lisa,1)
ystep<-hseq[2]-hseq[1]
yapu[lisa:1]<-seq(hseq[1]-ystep,hseq[1]-ystep*lisa,-ystep)
yapu[(lisa+1):(length(hseq)+lisa)]<-hseq

# add colors to the end 
levelo<-lisa*(dim(zapu)[1]-1)
colapu<-matrix("",length(colot)+levelo,1)
colapu[1:length(colot)]<-colot
colapu[(length(colot)+1):length(colapu)]<-colot[(length(colot)-levelo+1):length(colot)]

return(list(level=level,h=yapu,z=zapu,col=colapu))
}





ccentebag<-function(component,AtomlistAtom,AtomlistNext,low,upp,volume,
step,suppo)
{
d<-dim(low)[2]

componum<-length(component)
center<-matrix(0,componum,d)

for (i in 1:componum){
   curcente<-matrix(0,d,1)
   pointer<-component[i]
   while (pointer>0){
        atompointer<-AtomlistAtom[pointer]
        
        newcente<-matrix(0,d,1)
        for (j in 1:d){
            # calculate 1st volume of d-1 dimensional rectangle where
            # we have removed j:th dimension

            vol<-1
            k<-1
            while (k<=d){
               if (k!=j){
                  vol<-vol*(upp[atompointer,k]-low[atompointer,k])*step[k]
               }
               k<-k+1
            }

            ala<-suppo[2*j-1]+step[j]*low[atompointer,j]
            yla<-suppo[2*j-1]+step[j]*upp[atompointer,j]
            newcente[j]<-vol*(yla^2-ala^2)/2
        }

        curcente<-curcente+newcente
        pointer<-AtomlistNext[pointer]
   }
   center[i,]<-curcente/volume[i]
}
return(t(center))
}

ccentedya<-function(volofatom,component,AtomlistNext,AtomlistAtom,
volume,minim,h,delta,index,d){
#
componum<-length(component)
center<-matrix(0,componum,d)
#
for (i in 1:componum){
   curcente<-0
   pointer<-component[i]
   while (pointer>0){
        atompointer<-AtomlistAtom[pointer]
        inde<-index[atompointer,]
        newcente<-minim-h+delta*inde
        curcente<-curcente+newcente
        pointer<-AtomlistNext[pointer]
   }
   center[i,]<-volofatom*curcente/volume[i]
}
return(t(center))
}
ccente<-function(levels,items,mass){
#Calculates centers from a collection of level sets.
#center is 1st moment didided by volume.
#
#levels is tasolkm*N-matrix of 1:s and 0:s
#items is N*(2*d)-matrix
#mass is tasolkm-vector
#
#returns N*d-matrix of 1st moments.
#
N<-length(levels[,1])
d<-length(items[1,])/2
res<-matrix(0,N,d)
if (dim(t(levels))[1]==1) tasolkm<-1 else tasolkm<-length(levels[,1]) 
for (i in 1:tasolkm){
  lev2<-change(levels[i,])
  m<-length(lev2)
  vol<-matrix(0,d,1)
  for (j in 1:m){
    ind<-lev2[j]
    rec<-items[ind,]
    vol<-vol+cenone(rec)
  }
  res[i,]<-vol/mass[i]
}
return(t(res))
}

 

cenone<-function(rec){
#Calculates the 1st moment of a rectangle.
#
#rec is (2*d)-vector, represents rectangle in d-space
#Returns a d-vector.
#
d<-length(rec)/2
res<-matrix(0,d,1)
for (j in 1:d){
  apurec<-rec      #apurec such that is volume is equal to
  apurec[2*j-1]<-0 #volume of d-1 dimensional rectangle where
  apurec[2*j]<-1   #we have removed j:th dimension
  vajmas<-massone(apurec) 
  res[j]<-vajmas*(rec[2*j]^2-rec[2*j-1]^2)/2  
}
return(res) 
}

cfrekv<-function(levels,arvot){
#laskee tasojoukon osien frekvenssit
#arvo on reaaliluku
#kumu on kork*n-matriisi, n saraketta, kuvaa kork kpl:tta tasojoukon osia
#1 jos vastaava data-matriisin rivin indikoima pallo kuuluu tasojouon osaan
#muodostetaan matriisi, jonka 1. sarakkeessa "arvo", 
#2. sarakkeessa kunkin tasojoukon osan frekvenssi  
#ts. laskettu kuinka monesta pallosta tasojoukko on yhdistetty
#
tasolkm<-length(levels[,1])     #levels:n rivien maara
frek<-matrix(0,tasolkm,1)
a<-1
while (a<=tasolkm){
   frek[a]<-sum(levels[a,]*arvot)
   a<-a+1 
}
return(t(frek))
}







change<-function(levset){
#
#
len<-length(levset)
m<-sum(levset)
rindeksit<-matrix(0,m,1)
j<-1
for (i in 1:len){
    if (levset[i]==1){
       rindeksit[j]<-i
       j<-j+1
    }
}
return(rindeksit)
}

cintemul<-function(roots,child,sibling,volume,level){
#
#integrate function, over the level of roots, in the region of roots
#
itemnum<-length(child)
rootnum<-length(roots)
inte<-0
for (i in 1:rootnum){
    pino<-matrix(0,itemnum,1)
    valpino<-matrix(0,itemnum,1)  #level of parent
    pino[1]<-roots[i]
    valpino[1]<-0
    sibling[roots[i]]<-0
    #    
    pinin<-1
    while (pinin>0){
        cur<-pino[pinin]      #take from stack
        valcur<-valpino[pinin] 
        pinin<-pinin-1
        #
        if (level[cur]>0){
           inte<-inte+(level[cur]-max(valcur,0))*volume[cur]
        }
        #
        if (sibling[cur]>0){
              pinin<-pinin+1
              pino[pinin]<-sibling[cur]
              valpino[pinin]<-valcur
        }
        while (child[cur]>0){    #go to left and put right nodes to stack
              valcur<-level[cur]
              cur<-child[cur]
              #
              if (level[cur]>0){
                 inte<-inte+(level[cur]-max(valcur,0))*volume[cur]
              }
              #
              if (sibling[cur]>0){  #if cur has siblings
                 pinin<-pinin+1
                 pino[pinin]<-sibling[cur]
                 valpino[pinin]<-valcur
             }
        }
    }
}
#
return(inte)
}

cinte<-function(values,volumes,parents){
#Calculates the integral of a piecewise continuous function.
#
len<-length(values)
int<-0
for (i in len:1){
  par<-parents[i]
  if (par==0) valpar<-0 
  else valpar<-values[par]
  int<-int+volumes[i]*(values[i]-valpar)
}
return(int)
}

colo2scem<-function(sp,mt,ca)
{
#sp result of scemprof
#mt result of modegraph
#ca result of coloallo
#origlis translates h-values from sp terminology to mt terminology

len<-length(sp$bigdepths)
mtlen<-length(ca)
colors<-matrix("black",len,1)

for (i in 1:len){
  label<-sp$mlabel[i]       #label for mode
  if (label>0){ 
      smoot<-sp$smoot[i]    #smoothing paramter value/leafnum
      # we find the corresponding slot from "ca" where
      # label corresponds and smoothing parameter value corresponds
      run<-1
      koesmoot<-mt$ycoor[run]
      koelabel<-mt$mlabel[run] 
      while (((koesmoot!=smoot) || (koelabel!=label)) && (run<=mtlen)){
         run<-run+1
         koesmoot<-mt$ycoor[run]
         koelabel<-mt$mlabel[run] 
      }
      # we have found the slot
      colors[i]<-ca[run]
  }
}

return(colors)
}








coloallo<-function(mt,paletti=NULL)
{
# fast allocation of colors (matching of modes)
# mt is mode tree
# paletti gives a list of colors

if (is.null(paletti))
paletti<-c("red","blue","green","turquoise","orange","navy",
"darkgreen","orchid",colors()[50:100])

d<-dim(mt$xcoor)[2]

snum<-0
for (i in 1:length(mt$mlabel)){
  if (mt$mlabel[i]==1) snum<-snum+1
}

xcoor<-mt$xcoor
ycoor<-mt$ycoor
mlabel<-mt$mlabel
lenni<-length(ycoor)

colot<-matrix("",lenni,1)

# find the locations for the information for each h

low<-matrix(0,snum,1)
upp<-matrix(0,snum,1)
low[1]<-1
glob<-2
while ((glob<=lenni) && (mlabel[glob]!=1)){
       glob<-glob+1
}
upp[1]<-glob-1
# now glob is at the start of new block
i<-2
while (i<=snum){
   low[i]<-glob
   glob<-glob+1
   while ((glob<=lenni) && (mlabel[glob]!=1)){
       glob<-glob+1
   }
   upp[i]<-glob-1
   i<-i+1
}

# first we allocate colors for the largest h

run<-1  #low[1]
while (run<=upp[1]){
   colot[run]<-paletti[run]
   run<-run+1
}

firstnewcolo<-run

i<-2

while (i<=snum){
   prenum<-upp[i-1]-low[i-1]+1
   curnum<-upp[i]-low[i]+1

   smallernum<-min(prenum,curnum)
   greaternum<-max(prenum,curnum)

   if (prenum==smallernum){   
        bases<-i
        compa<-i-1
   }
   else{
        bases<-i-1
        compa<-i
   }

      dista<-matrix(NA,smallernum,greaternum)
      for (ap in low[bases]:upp[bases]){
         for (be in low[compa]:upp[compa]){
           if (d==1){
               curcenter<-xcoor[ap]
               precenter<-xcoor[be]
           }
           else{
               curcenter<-xcoor[ap,]
               precenter<-xcoor[be,]
           }
           dista[be-low[compa]+1,ap-low[bases]+1]<-etais(curcenter,precenter)
         }
      }

      match<-matrix(0,smallernum,1)  #for each mode the best match
      findtie<-TRUE

      # find the best match for all and check whether there are ties
      match<-matrix(0,smallernum,1)
      for (bm in 1:smallernum){
          minimi<-min(dista[bm,],na.rm=TRUE)
          match[bm]<-which(minimi==dista[bm,])[1]
      }
      findtie<-FALSE
      bm<-1
      while ((bm<=smallernum) && (findtie==FALSE)){
         koe<-match[bm]
         bm2<-bm+1
         while (bm2<=smallernum){
            if (koe==match[bm2]){
                  findtie<-TRUE
            }
            bm2<-bm2+1
         }
         bm<-bm+1
      }
    
      onkayty<-FALSE

      while (findtie){

      onkayty<-TRUE
      tiematch<-matrix(0,smallernum,1)
      
      # find the best match for all
      bestmatch<-matrix(0,smallernum,1)
      for (bm in 1:smallernum){
          allna<-TRUE
          am<-1
          while ((am<=greaternum) && (allna)){
             if (!is.na(dista[bm,am])) allna<-FALSE
             am<-am+1
          }
          if (!(allna)){
             minimi<-min(dista[bm,],na.rm=TRUE)
             bestmatch[bm]<-which(minimi==dista[bm,])[1]
          }
          else bestmatch[bm]<-match[bm]
      }

      # find the first tie
      findtie<-FALSE

      tieset<-matrix(0,smallernum,1)
      bm<-1
      while ((bm<=smallernum) && (findtie==FALSE)){
         koe<-bestmatch[bm]
         bm2<-bm+1
         while (bm2<=smallernum){
            if (koe==bestmatch[bm2]){
                  findtie<-TRUE
                  tieset[bm]<-1
                  tieset[bm2]<-1
            }
            bm2<-bm2+1
         }
         bm<-bm+1
      }

      # solve the first tie
      if (findtie==TRUE){
         numofties<-sum(tieset)
         kavelija<-0
         tiepointer<-matrix(0,numofties,1) 
         # find the second best
         secondbest<-matrix(0,smallernum,1)
         for (bm in 1:smallernum){
            if (tieset[bm]==1){
               redudista<-dista[bm,]
               redudista[bestmatch[bm]]<-NA
               minimi<-min(redudista,na.rm=TRUE)
               secondbest[bm]<-which(minimi==redudista)[1]

               kavelija<-kavelija+1
               tiepointer[kavelija]<-bm
            }
         }
         # try different combinations       
         # try all subsets of size 2 from the set of ties
         numofsubsets<-choose(numofties,2)
            #gamma(numofties+1)/gamma(numofties-2+1)
         valuelist<-matrix(0,numofsubsets,1)
         vinnerlist<-matrix(0,numofsubsets,1)
         matchlist<-matrix(0,numofsubsets,1)
         runneri<-1
         eka<-1
         while (eka<=numofties){
            ekapo<-tiepointer[eka]
            toka<-eka+1
            while (toka<=numofties){
               tokapo<-tiepointer[toka]
               # try combinations for this subset (there are 2)
               # 1st combination
               fvinner<-ekapo
               fvinnermatch<-bestmatch[fvinner]
               floser<-tokapo
               flosermatch<-secondbest[floser]
               fvalue<-dista[fvinner,fvinnermatch]+dista[floser,flosermatch]
                # 2nd combination
               svinner<-tokapo
               svinnermatch<-bestmatch[svinner]
               sloser<-ekapo
               slosermatch<-secondbest[sloser]
               svalue<-dista[svinner,svinnermatch]+dista[sloser,slosermatch]
               # tournament
               if (fvalue<svalue){
                   valuelist[runneri]<-fvalue
                   vinnerlist[runneri]<-fvinner
                   matchlist[runneri]<-fvinnermatch
               }
               else{ 
                   valuelist[runneri]<-svalue
                   vinnerlist[runneri]<-svinner
                   matchlist[runneri]<-svinnermatch
               }
               runneri<-runneri+1 
               # 
               toka<-toka+1
            }
            eka<-eka+1
         }
         minimi<-min(valuelist,na.rm=TRUE)
         bestsub<-which(minimi==valuelist)[1]
         vinnerson<-vinnerlist[bestsub]
         matcherson<-matchlist[bestsub]

         tiematch[vinnerson]<-matcherson
         dista[vinnerson,]<-NA
         dista[,matcherson]<-NA

      }

      }  #while (findtie)

      if (onkayty){  #there was one tie
          
          for (sepo in 1:smallernum){
               if (tiematch[sepo]!=0) match[sepo]<-tiematch[sepo]
               else match[sepo]<-bestmatch[sepo]
          }
      }

      # finally allocate colors
      run<-1
      while (run<=smallernum){
          
          if (prenum==smallernum){
             xind<-run
             yind<-match[xind]
          }
          else{
             yind<-run
             xind<-match[yind]
          }

          colot[low[i]+yind-1]<-colot[low[i-1]+xind-1]    
          run<-run+1
      }
                    
      if (prenum<greaternum){

        run<-low[bases]
        while (run<=upp[bases]){
            if (colot[run]==""){
               colot[run]<-paletti[firstnewcolo]
               firstnewcolo<-firstnewcolo+1   
            }
            run<-run+1
        }

     }

     i<-i+1
}

return(colot)
}


















colobary<-function(parent,paletti,roots=NULL,
modecolo=NULL,modepointer=NULL #,segtype="char"
)
{
nodenum<-length(parent)
#if (segtype=="char") colot<-matrix("",nodenum,1) 
#else 
colot<-matrix(0,nodenum,1)

fb<-findbranch(parent)$indicator
modloc<-moodilkm(parent)$modloc
#if (repretype=="B"){
#   fb<-findbranchB(parent,roots)$indicator
#   modloc<-moodilkmB(parent)$modloc
#}

moodilkm<-length(modloc)
palerun<-0

# first allocate colors for modes
if (is.null(modecolo)){
   i<-1
   while (i<=moodilkm){
       cur<-modloc[i]
       palerun<-palerun+1
       colot[cur]<-paletti[palerun]
       i<-i+1
   }
}
else{
   # remove modecolo:s from paletti
   indu<-0
   for (pp in 1:length(paletti)) 
       for (ppp in 1:length(modecolo))
          if (paletti[pp]==modecolo[ppp]){ 
                 indu<-indu+1
                 paletti[pp]<-colors()[100+indu] 
          }
   
   i<-1
   while (i<=moodilkm){
       cur<-modepointer[i]
       colot[cur]<-modecolo[i]
       i<-i+1
   } 
}

# then allocate for others
i<-1
while (i<=moodilkm){
 
  cur<-modloc[i]
  while (parent[cur]>0){

     child<-parent[cur]

     if ((fb[cur]==1) && (colot[child]==0)){ #cur is a result of a branch 
           palerun<-palerun+1
           colot[child]<-paletti[palerun]
     }      
     else if (colot[child]==0) colot[child]<-colot[cur]

     cur<-child
  }
  i<-i+1
}

return(colot)
}    


colobary.roots<-function(parent,level,colothre=min(level),paletti=NULL)
{
mt<-multitree(parent) #roots<-mt$roots child<-mt$child sibling<-mt$sibling

itemnum<-length(mt$child)
colot<-matrix("",itemnum,1)
rootnum<-length(mt$roots)
if (is.null(paletti))
 paletti<-c("red","blue","green",
 "orange","navy","darkgreen",
 "orchid","aquamarine","turquoise",
 "pink","violet","magenta","chocolate","cyan",
 colors()[50:657],colors()[50:657])
hep<-1

for (i in 1:rootnum){
   curroot<-mt$roots[i]
   colot[curroot]<-paletti[hep]
   hep<-hep+1
   if (mt$child[curroot]>0){
      pino<-matrix(0,itemnum,1)
      pino[1]<-mt$child[curroot]
      pinin<-1
      while (pinin>0){
          cur<-pino[pinin]      #take from stack
          pinin<-pinin-1
          if ((mt$sibling[cur]==0)||(level[parent[cur]]<colothre)) 
              colot[cur]<-colot[parent[cur]]
          else{ 
                colot[cur]<-paletti[hep]
                hep<-hep+1
          } 
          # put to the stack 
          if (mt$sibling[cur]>0){
                 pinin<-pinin+1
                 pino[pinin]<-mt$sibling[cur]
          }
          # go to left and put right nodes to the stack
          while (mt$child[cur]>0){   
             cur<-mt$child[cur]
             if ((mt$sibling[cur]==0)||(level[parent[cur]]<colothre)) 
                       colot[cur]<-colot[parent[cur]]
             else{ 
                    colot[cur]<-paletti[hep]
                    hep<-hep+1
             } 
             if (mt$sibling[cur]>0){
                 pinin<-pinin+1
                 pino[pinin]<-mt$sibling[cur]
             }
           }
       }#while (pinin>0)
   }
}                           
return(colot)
}




cumu<-function(values,recs,frekv=NULL){
#Finds level sets of a piecewise constant function 
#
#values is recnum-vector
#recs is recnum*(2*d)-matrix
#frekv is recnum-vector
#
#returns list(levels,lsets,recs)
#   levels is levnum-vector,
#   lsets is levnum*atomnum-matrix,
#   atoms is recs but rows in different order
#   frekv is also only ordered differently

jarj<-omaord(values,recs,frekv)
values<-jarj$values
recs<-jarj$recs
frekv<-jarj$frekv
recnum<-length(values) #=length(recs[,1])#numb of lev is in the worst case
levels<-matrix(0,recnum,1)      
lsets<-matrix(1,recnum,recnum)  #same as the number of recs
       #at the beginning we mark everything belonging to level sets
       #next we start removing recs from level sets
levels[1]<-values[1]    #smallest values are first, first row of levels
                       #contains already 1:s 
curval<-values[1]
curlev<-1
for (i in 1:recnum){
  if (values[i]<=curval) lsets[(curlev+1):recnum,i]<-0
    else{
      curlev<-curlev+1      
      curval<-values[i]
      levels[curlev]<-values[i]
      if ((curlev+1)<=recnum) lsets[(curlev+1):recnum,i]<-0
    }
}
levels<-levels[1:curlev]
lsets<-lsets[1:curlev,]
return(list(levels=levels,lsets=lsets,atoms=recs,frekv=frekv))
}
cutmut<-function(mut,level,levels){
#
roots<-mut$roots
child<-mut$child
sibling<-mut$sibling
#
itemnum<-length(child)
rootnum<-length(roots)       
#
newroots<-matrix(0,itemnum,1)
newsibling<-sibling
ind<-0
#
for (i in 1:rootnum){
      curroot<-roots[i]
      pino<-matrix(0,itemnum,1)
      pino[1]<-curroot
      pinin<-1
      while (pinin>0){
          cur<-pino[pinin]      #take from stack
          pinin<-pinin-1
          # 
          # if cur acrosses the level, make cur root
          if (levels[cur]>level){
             ind<-ind+1
             newroots[ind]<-cur     # add to list
             newsibling[cur]<-0     # remove siblings
          }               
          # put to the stack
          if (sibling[cur]>0){
                 pinin<-pinin+1
                 pino[pinin]<-sibling[cur]
          }
          # go to left and put right nodes to the stack
          # if we have not already crossed the level
          while ((child[cur]>0) && (levels[cur]<=level)){
             cur<-child[cur]
             # if cur acrosses the level, make cur root
             if (levels[cur]>level){
                ind<-ind+1
                newroots[ind]<-cur  # add to list
                newsibling[cur]<-0     # remove siblings
             }  
             if (sibling[cur]>0){
                 pinin<-pinin+1
                 pino[pinin]<-sibling[cur]
             }
           }
       }
}                                        
if (ind>0){
    newroots<-newroots[1:ind]
}
else{
    newroots<-NULL
}
return(list(roots=newroots,sibling=newsibling))
}





cutvalue<-function(roots,child,sibling,level,component,
          AtomlistAtom,AtomlistNext,valnum){
#
#from the cutted multitree, form a "newvalue",
#which gives quantized values for the kernel estimate,
#in addition the values are cutted, so that one mode is 
#removed (input is cutted multitree)
#
itemnum<-length(child)
rootnum<-length(roots)
newvalue<-matrix(0,valnum,1)

for (i in 1:rootnum){
    pino<-matrix(0,itemnum,1)
    pino[1]<-roots[i]
    #    
    pinin<-1
    while (pinin>0){
        cur<-pino[pinin]      #take from stack
        pinin<-pinin-1
        #
        node<-cur
        compo<-component[node]
        ato<-compo                          #ato is pointer to "value"
        while (ato>0){
           newvalue[AtomlistAtom[ato]]<-level[node]
           ato<-AtomlistNext[ato]
        }
        #
        if (sibling[cur]>0){
              pinin<-pinin+1
              pino[pinin]<-sibling[cur]
        }
        while (child[cur]>0){    #go to left and put right nodes to stack
              cur<-child[cur]
              #
              node<-cur
              compo<-component[node]
              ato<-compo                    #ato is pointer to "value"
              while (ato>0){
                  newvalue[AtomlistAtom[ato]]<-level[node]
                  ato<-AtomlistNext[ato]
              }
              #
              if (sibling[cur]>0){  #if cur has siblings
                 pinin<-pinin+1
                 pino[pinin]<-sibling[cur]
             }
        }
    }
}
#
return(newvalue)
}


cvolumbag<-function(component,AtomlistAtom,AtomlistNext,low,upp,steppi)
{
d<-dim(low)[2]

componum<-length(component)
volume<-matrix(0,componum,1)

for (i in 1:componum){
   curvolu<-0
   pointer<-component[i]
   while (pointer>0){
        atto<-AtomlistAtom[pointer]

        vol<-1
        for (j in 1:d){
            vol<-vol*(upp[atto,j]-low[atto,j])*steppi[j]
        }

        curvolu<-curvolu+vol
        pointer<-AtomlistNext[pointer]
   }
   volume[i]<-curvolu
}
return(volume)
}
cvolumdya<-function(volofatom,component,AtomlistNext){
#
componum<-length(component)
volume<-matrix(0,componum,1)
#
# it is enough to calculate the number of aoms in each component
for (i in 1:componum){
   numofatoms<-0
   pointer<-component[i]
   while (pointer>0){
        numofatoms<-numofatoms+1
        pointer<-AtomlistNext[pointer]
   }
   volume[i]<-numofatoms*volofatom
}
return(volume)
}
cvolum<-function(levels,items){
#Calculates volumes of set of level sets
#
#levels is tasolkm*N-matrix of 1:s and 0:s
#items is N*(2*d)-matrix
#
#returns N-vector of volumes
#
N<-length(levels[,1])
res<-matrix(0,N,1)
if (dim(t(levels))[1]==1) tasolkm<-1 else tasolkm<-length(levels[,1]) 
for (i in 1:tasolkm){
  lev2<-change(levels[i,])
  m<-length(lev2)
  vol<-0
  for (j in 1:m){
    ind<-lev2[j]
    rec<-items[ind,]
    vol<-vol+massone(rec)
  }
  res[i]<-vol
}
return(t(res))
}


 

declevdya<-function(beg,AtomlistNext,AtomlistAtom,kg,N,nodenumOfDyaker,
terminalnum,d){
#
#beg is pointer to AtomlistAtom
#nodenumOfDyaker is the num of nodes of the _original dyaker_
#terminalnum is the num of terminal nodes of the "current dyaker"
#
#kg=kernel estimate is represented as binary tree with "nodenumOfDyaker" nodes:
#   vectors whose length is "nodenum":
#     -left,right,parent
#     -infopointer: pointer to "value" and "index" (only for terminal nodes)
#   additional data structures  
#     -value, index
#
#to be created:
#-separy, vector with length "nodenumOfDyaker", points to begsSepaBegs
#-begsSepaBegs, begsSepaNext, begsLeftBoun, begsRighBoun
#   vectors of same length as "value" and "index",
#   list of separate sets, index gives starting point for set in atomsSepaNext
#-atomsSepaAtom, atomsSepaNext, atomsLBounNext, atomsRBounNext
#   vector of same length as "value" and "index",
#   list of atoms in separate sets, index gives the atom in value and index
#
#return: 
#begs: list of beginnings of lists
#AtomlistAtoms, AtomlistNext: list of lists of atoms
#
left<-kg$left
right<-kg$right
parent<-kg$parent
index<-kg$index
nodefinder<-kg$nodefinder
#infopointer<-kg$infopointer
#
separy<-matrix(0,nodenumOfDyaker,1)
#
begsSepaNext<-matrix(0,terminalnum,1)
begsSepaBegs<-matrix(0,terminalnum,1)   #pointers to begsSepaAtoms
begsLeftBoun<-matrix(0,terminalnum,1)
begsRighBoun<-matrix(0,terminalnum,1)
#
atomsSepaNext<-matrix(0,terminalnum,1)  #pointers to value,index
atomsSepaAtom<-matrix(0,terminalnum,1)
atomsLBounNext<-matrix(0,terminalnum,1)
atomsRBounNext<-matrix(0,terminalnum,1)
#
nextFloor<-matrix(0,terminalnum,1)
currFloor<-matrix(0,terminalnum,1)
already<-matrix(0,nodenumOfDyaker,1)
#
#############################
# INITIALIZING: "we go through the nodes at depth "depoftree""
# we make currFloor to be one over bottom floor and initialize 
# separy, boundary, atomsSepaAtom, atomsBounAtom
##############################
#
lkm<-0
curlkm<-0
curre<-beg
while(curre>0){
    lkm<-lkm+1
    atom<-AtomlistAtom[curre]
    node<-nodefinder[atom]
    #
    separy[node]<-lkm
    atomsSepaAtom[lkm]<-atom
    #
    exists<-parent[node]
    if (already[exists]==0){
         curlkm<-curlkm+1
         currFloor[curlkm]<-exists 
         already[exists]<-1
    }
    #
    curre<-AtomlistNext[curre]
}     # obs terminalnum=lkm
# initialize the rest
begsSepaBegs[1:terminalnum]<-seq(1,terminalnum)       
begsLeftBoun[1:terminalnum]<-seq(1,terminalnum)
begsRighBoun[1:terminalnum]<-seq(1,terminalnum)
#obs: we need not change 
#begsSepaNext, atomsSepaNext, atomsLBounNext, atomsRBounNext
#since at the beginning set consist only one member:
#pointer is always 0, since we do not have followers 
#
###########################
#
# START the MAIN LOOP
###########################
i<-d
while (i >= 2){
   j<-log(N[i],base=2)   #depth at direction d
   while (j>=1){
        nexlkm<-0
        k<-1
        while (k <= curlkm){
            node<-currFloor[k]  
            # we create simultaneously the upper floor
            exists<-parent[node]
            if (already[exists]==0){
                 nexlkm<-nexlkm+1
                 nextFloor[nexlkm]<-exists
                 already[exists]<-1
            }
####################################################
#            now we join childs            
####################################################
            leftbeg<-left[node]
            rightbeg<-right[node]
            direction<-i
            jg<-joingene(node,leftbeg,rightbeg,separy,
begsSepaNext,begsSepaBegs,begsLeftBoun,begsRighBoun,
atomsSepaNext,atomsSepaAtom,atomsLBounNext,atomsRBounNext,
direction,index)
#
separy<-jg$separy
begsSepaNext<-jg$begsSepaNext
begsSepaBegs<-jg$begsSepaBegs
begsLeftBoun<-jg$begsLeftBoun
begsRighBoun<-jg$begsRighBoun
atomsSepaNext<-jg$atomsSepaNext
atomsSepaAtom<-jg$atomsSepaAtom
atomsLBounNext<-jg$atomsLBounNext
atomsRBounNext<-jg$atomsRBounNext
           k<-k+1
        }
        j<-j-1
        curlkm<-nexlkm
        currFloor<-nextFloor
   }
   # now we move to the next direction, correct boundaries
   begsLeftBoun<-begsSepaBegs
   begsRighBoun<-begsSepaBegs
   #
   atomsLBounNext<-atomsSepaNext
   atomsRBounNext<-atomsSepaNext
   #
   i<-i-1
}
#########################
# ENO OF MAIN LOOP
#########################
#
#
###################
# LAST DIMENSION WILL BE handled, (because this contains root node
##################
   i<-1
   j<-log(N[i],base=2)   #depth at direction d
   while (j>=2){
        nexlkm<-0
        k<-1
        while (k <= curlkm){
            node<-currFloor[k]  
            # we create simultaneously the upper floor
            exists<-parent[node]
            if (already[exists]==0){
                 nexlkm<-nexlkm+1
                 nextFloor[nexlkm]<-exists
                 already[exists]<-1
            }
####################################################
#            now we join childs            
#if (right[parent[node]]==node)  #if node is right child 
####################################################
            leftbeg<-left[node]
            rightbeg<-right[node]
            direction<-1 
jg<-joingene(node,leftbeg,rightbeg,separy,
begsSepaNext,begsSepaBegs,begsLeftBoun,begsRighBoun,
atomsSepaNext,atomsSepaAtom,atomsLBounNext,atomsRBounNext,
direction,index)
#
separy<-jg$separy
begsSepaNext<-jg$begsSepaNext
begsSepaBegs<-jg$begsSepaBegs
begsLeftBoun<-jg$begsLeftBoun
begsRighBoun<-jg$begsRighBoun
#
atomsSepaNext<-jg$atomsSepaNext
atomsSepaAtom<-jg$atomsSepaAtom
atomsLBounNext<-jg$atomsLBounNext
atomsRBounNext<-jg$atomsRBounNext
           k<-k+1
        }
        j<-j-1
        curlkm<-nexlkm
        currFloor<-nextFloor
   }
#########################
# ROOT NODE, we do not anymore update boundaries
#########################
            k<-1
            node<-currFloor[k]  
  while (k <= 1){
####################################################
#            now we join childs            
#if (right[parent[node]]==node)  #if node is right child 
####################################################
            leftbeg<-left[node]
            rightbeg<-right[node]
            if ((leftbeg==0) || (separy[leftbeg]==0)){
                              #if left child does not exist    
                separy[node]<-separy[rightbeg]
            }
            else{   #eka else
                if ((rightbeg==0) || (separy[rightbeg]==0)){  
                              #right child does not exist  
                   separy[node]<-separy[leftbeg]
                } 
                else{   #toka else: both children exist
                    #check whether left boundary of right child is empty
                    Lempty<-TRUE
                    note<-separy[rightbeg]
                    while (note>0){
                        if (begsLeftBoun[note]>0){
                              Lempty<-FALSE
                        }
                        note<-begsSepaNext[note]
                     }
                     #check whether right bound of left child is empty     
                     Rempty<-TRUE
                     note<-separy[leftbeg]
                     while (note>0){
                          if (begsRighBoun[note]>0){
                                 Rempty<-FALSE
                          }
                          note<-begsSepaNext[note]
                     }
                     #check whether one of boundaries is empty
                     if (Lempty || Rempty){
                            #one of boundaries is empty         
############
#concatenating separate parts
#separy[node]<- concatenate separy[leftbeg],separy[rightbeg]
###########
akku<-separy[leftbeg]
while (begsSepaNext[akku]>0){
  akku<-begsSepaNext[akku]
}                           
begsSepaNext[akku]<-separy[rightbeg]
#
separy[node]<-separy[leftbeg]
####################
#end of concatenating, handle next boundaries
###################
                    }
                    else{  #both children exist, both boundaries non-empty  
direction<-i
jc<-joinconne(leftbeg,rightbeg,separy,
begsSepaNext,begsSepaBegs,begsLeftBoun,begsRighBoun,
atomsSepaNext,atomsSepaAtom,atomsLBounNext,atomsRBounNext,
direction,index)  #direction<-i
#
separy<-jc$separy
separy[node]<-jc$totbegSepary 
#
begsSepaNext<-jc$begsSepaNext
begsSepaBegs<-jc$begsSepaBegs
begsLeftBoun<-jc$begsLeftBoun
begsRighBoun<-jc$begsRighBoun
#
atomsSepaNext<-jc$atomsSepaNext
atomsSepaAtom<-jc$atomsSepaAtom
atomsLBounNext<-jc$atomsLBounNext
atomsRBounNext<-jc$atomsRBounNext
                        #
                    }
                } #toka else
            } #eka else
 k<-k+1
}
###########################################
#          end of child joining
###########################################
###################################
# END of ROOT
###################################
#
###########################
###########################
totbegSepary<-separy[node]
return(list(totbegSepary=totbegSepary,
begsSepaNext=begsSepaNext,begsSepaBegs=begsSepaBegs,
atomsSepaNext=atomsSepaNext,atomsSepaAtom=atomsSepaAtom))
}













declevgen<-function(tobehandled,curterminalnum,
left,right,val,vec,infopointer,parent,
low,upp,
d)
# source("~/denpro/R/declevgen.R")
# dl<-declevgen(tobehandled,curterminalnum,left,right,val,vec,
# infopointer,parent,low,upp,d)

{
nodelkm<-length(left)

separy<-matrix(0,nodelkm,1)          #=infopointer?

begsSepaNext<-matrix(0,curterminalnum,1)
begsSepaBegs<-matrix(0,curterminalnum,1)    #pointers to begsSepaAtom
begsLeftBoun<-matrix(0,curterminalnum,1)
begsRighBoun<-matrix(0,curterminalnum,1)

atomsSepaNext<-matrix(0,curterminalnum,1)   #pointers to value,index
atomsSepaAtom<-matrix(0,curterminalnum,1)
atomsLBounNext<-matrix(0,curterminalnum,1)
atomsRBounNext<-matrix(0,curterminalnum,1)

leafloc<-findleafs(left,right)

lkm<-0
node<-nodelkm
while (node>=1){ 
          # root is in position 1
    if ((leafloc[node]==1) && (tobehandled[node]==1)){   #we are in leaf 

          tobehandled[parent[node]]<-1

          lkm<-lkm+1
          separy[node]<-lkm
          atomsSepaAtom[lkm]<-infopointer[node]

          begsSepaBegs[lkm]<-lkm

          #begsLeftBoun[lkm]<-lkm
          #begsRighBoun[lkm]<-lkm

          #obs: we need not change
          #begsSepaNext, atomsSepaNext, atomsLBounNext, atomsRBounNext
          #since at the beginning set consist only one member:
          #pointer is always 0, since we do not have followers

    }
    else if (tobehandled[node]==1){   #not a leaf

        tobehandled[parent[node]]<-1

        leftbeg<-left[node]
        rightbeg<-right[node]

        if ((leftbeg==0) || (separy[leftbeg]==0)){
           #if left child does not exist

           #note that since we consider subsets of the
           #terminal nodes of the original tree, it may happen
           #that leftbeg>0 but left child does not exist
          
           separy[node]<-separy[rightbeg]

           #we need that all lists contain as many members
           #left boundary is empty, but we will make it a list
           #of empty lists

           #note<-separy[node]
           #while (note>0){
           #    begsLeftBoun[note]<-0
           #    note<-begsSepaNext[note]
           #}
           # right boundary stays same as for rightbeg
        }
        else{   # eka else
            if ((rightbeg==0) || (separy[rightbeg]==0)){
            #right child does not exist
    
                   separy[node]<-separy[leftbeg]
    
                   # left boundary stays same as for leftbeg
                   # right boundary is empty
    
                   #note<-separy[node]
                   #while (note>0){
                   #    begsRighBoun[note]<-0
                   #    note<-begsSepaNext[note]
                   #}
            }
            else{   #toka else: both children exist
                    #create boundaries 
                    
                    direktiooni<-vec[node]
                    splittiini<-val[node]     
               
                    #left boundary of right child :
                    #create/check whether empty 
                   
                    Lempty<-TRUE
                    note<-separy[rightbeg]
                    while (note>0){
                        thisnoteempty<-TRUE

                        poiju<-begsSepaBegs[note]
                        prevpoiju<-poiju 
                        while (poiju>0){
                           aatto<-atomsSepaAtom[poiju]
                           if (!(splittiini<low[aatto,direktiooni])){
                               #this atom belongs to boundary
                               if (thisnoteempty==TRUE){
                                   #poiju is the 1st non-empty
                                   begsLeftBoun[note]<-poiju
                               }                
                               Lempty<-FALSE   
                               atomsLBounNext[prevpoiju]<-poiju    
                               atomsLBounNext[poiju]<-0
                               prevpoiju<-poiju

                               thisnoteempty<-FALSE
                           }
                           poiju<-atomsSepaNext[poiju]
                        }
                        if (thisnoteempty) begsLeftBoun[note]<-0
                        note<-begsSepaNext[note]
                     }

                     #right boundary of left child

                     Rempty<-TRUE
                     note<-separy[leftbeg]
                     while (note>0){
                        thisnoteempty<-TRUE
                       
                        poiju<-begsSepaBegs[note]
                        prevpoiju<-poiju 
                        while (poiju>0){
                           aatto<-atomsSepaAtom[poiju]
                           if (!(splittiini>upp[aatto,direktiooni])){
                               #this atom belongs to boundary
                               if (thisnoteempty==TRUE){
                                   #poiju is the 1st non-empty
                                   begsRighBoun[note]<-poiju
                               }                
                               Rempty<-FALSE   
                               atomsRBounNext[prevpoiju]<-poiju    
                               atomsRBounNext[poiju]<-0
                               prevpoiju<-poiju 
                           
                               thisnoteempty<-FALSE
                           }
                           poiju<-atomsSepaNext[poiju]
                        }
                        if (thisnoteempty) begsRighBoun[note]<-0
                        note<-begsSepaNext[note]
                     }

                     #check whether one of boundaries is empty

                     if (Lempty || Rempty){
                        #one of boundaries is empty
                        ############
                        #concatenating separate parts
                        ############
                        akku<-separy[leftbeg]
                        #begsRighBoun[akku]<-0 
                        # right boundaries of sets in left child are empty
                        # begsLeftBoun[akku] does not change
                        
                        #while (begsSepaNext[akku]>0){
                        #    akku<-begsSepaNext[akku]
                        #    begsRighBoun[akku]<-0
                        #}
                        begsSepaNext[akku]<-separy[rightbeg] 
                        #concatenate list of separate sets

                        separy[node]<-separy[leftbeg]
                        akku<-separy[rightbeg]
                          
                        #begsLeftBoun[akku]<-0 
                        #left boundaries of sets in right child are empty

                        #while (begsSepaNext[akku]>0){
                        #   akku<-begsSepaNext[akku]
                        #   begsLeftBoun[akku]<-0
                        #}
                        ############# 
                        #end of concatenating
                        #############
                     }
                     else{  #both children exist, both boundaries non-empty
                     direction<-vec[node]
                     jc<-joincongen(leftbeg,rightbeg,separy,
                     begsSepaNext,begsSepaBegs,begsLeftBoun,begsRighBoun,
                     atomsSepaNext,atomsSepaAtom,atomsLBounNext,atomsRBounNext,
                     direction,low,upp)   
                      
                     separy<-jc$separy
                     separy[node]<-jc$totbegSepary

                     begsSepaNext<-jc$begsSepaNext
                     begsSepaBegs<-jc$begsSepaBegs
                     #begsLeftBoun<-jc$begsLeftBoun
                     #begsRighBoun<-jc$begsRighBoun

                     atomsSepaNext<-jc$atomsSepaNext
                     atomsSepaAtom<-jc$atomsSepaAtom
                     #atomsLBounNext<-jc$atomsLBounNext
                     #atomsRBounNext<-jc$atomsRBounNext
                     }
            } #toka else
        } #eka else
    }  #else not a leaf
    node<-node-1
}

return(list(
totbegSepary=separy[1],
begsSepaNext=begsSepaNext,
begsSepaBegs=begsSepaBegs,
atomsSepaNext=atomsSepaNext,
atomsSepaAtom=atomsSepaAtom
))
}













declevnew<-function(rindeksit,linkit,n){
#Splits level set to disconnected subsets
#
#rindeksit is m-vector, links to observations, levset is union of m atoms
#linkit is n*n-matrix, n is the total number of atoms,
#  describes which atoms touch each other
#
#Returns sublevnum*n-matrix, describes disconnected parts of levset  
#
m<-length(rindeksit)
tulos<-matrix(0,m,n)      #in the worst case we split to m parts
#                         #blokit !!!!!!!!!!!!!!!!
merkatut<-matrix(0,m,1) #laitetaan 1 jos on jo sijoitettu johonkin tasojouk.
pino<-matrix(0,m,1) #pinoon laitetaan aina jos koskettaa, max kosketuksia m
pinind<-0           #pinossa viitataan rindeksin elementteihin
curleima<-1
i<-1   #i ja j viittavat rindeksit-vektoriin, jonka alkiot viittavat atomeihin
while (i<=m){
  if (merkatut[i]==0){  #jos ei viela merkattu niin 
    pinind<-pinind+1    #pannaan pinoon
    pino[pinind]<-i    
    while (pinind>0){
      curviite<-pino[pinind]  #otetaan pinosta viite rindeksit-vektoriin
                              #jossa puolestaan viitteet itse palloihin
      curpallo<-rindeksit[curviite]  #haetaan viite palloon
      pinind<-pinind-1  
      tulos[curleima,curpallo]<-1    #laitetaan pallo ko tasojoukkoon
#      merkatut[curviite]<-1          #merkataan kaytetyksi
      j<-1
      while (j<=m){          #pannnaan linkeista pinoon
        ehdokas<-rindeksit[j]         #kaydaan ko tasojoukon atomit lapi
        touch<-(linkit[curpallo,ehdokas]==1)
        if ((touch) && (merkatut[j]==0)){
          pinind<-pinind+1      
          pino[pinind]<-j  
          merkatut[j]<-1
        }
        j<-j+1
      }
    }
    curleima<-curleima+1   #uusi leima
  }
  i<-i+1
} 
tullos<-matrix(0,(curleima-1),n)
tullos[1:(curleima-1),]<-tulos[1:(curleima-1),] #poistetaan ylimaaraiset
return(tullos)
}


















declev<-function(rindeksit,linkit,n){
#Splits level set to disconnected subsets
#
#rindeksit is m-vector, links to observations, levset is union of m atoms
#linkit is n*n-matrix, n is the total number of atoms,
#  describes which atoms touch each other
#
#Returns sublevnum*n-matrix, describes disconnected parts of levset  
#
m<-length(rindeksit)
tulos<-matrix(0,m,n)      #in the worst case we split to m parts
#                         #blokit !!!!!!!!!!!!!!!!
merkatut<-matrix(0,m,1) #laitetaan 1 jos on jo sijoitettu johonkin tasojouk.
pino<-matrix(0,m,1) #pinoon laitetaan aina jos koskettaa, max kosketuksia m
pinind<-0           #pinossa viitataan rindeksin elementteihin
curleima<-1
i<-1   #i ja j viittavat rindeksit-vektoriin, jonka alkiot viittavat atomeihin
while (i<=m){
  if (merkatut[i]==0){  #jos ei viela merkattu niin 
    pinind<-pinind+1    #pannaan pinoon
    pino[pinind]<-i    
    while (pinind>0){
      curviite<-pino[pinind]  #otetaan pinosta viite rindeksit-vektoriin
                              #jossa puolestaan viitteet itse palloihin
      curpallo<-rindeksit[curviite]  #haetaan viite palloon
      pinind<-pinind-1  
      tulos[curleima,curpallo]<-1    #laitetaan pallo ko tasojoukkoon
#      merkatut[curviite]<-1          #merkataan kaytetyksi
      j<-1
      while (j<=m){          #pannnaan linkeista pinoon
        curkoske<-linkit[curpallo,]   #ne joihin curpallo koskettaa
        ehdokas<-rindeksit[j]         #kaydaan ko tasojoukon atomit lapi
        touch<-onko(curkoske,ehdokas) #onko ehdokas rivilla "curkoske"
            #touch<-(linkit[curpallo,rindeksit[j]]==1)
        if ((touch) && (merkatut[j]==0)){
          pinind<-pinind+1      
          pino[pinind]<-j  
          merkatut[j]<-1
        }
        j<-j+1
      }
    }
    curleima<-curleima+1   #uusi leima
  }
  i<-i+1
} 
tullos<-matrix(0,(curleima-1),n)
tullos[1:(curleima-1),]<-tulos[1:(curleima-1),] #poistetaan ylimaaraiset
return(tullos)
}


















decombag<-function(numofall,levseq,
left,right,val,vec,infopointer,parent,
nodenumOfTree,terminalnum,
value,low,upp,nodefinder,
d)
{
#Makes density tree
#returns list(parent,level,component)
#  -component is pointer to AtomlistAtom, AtomlistNext, ei tarvita

#apu2<-0

levnum<-length(levseq)

AtomlistNext<-matrix(0,numofall,1)
AtomlistAtom<-matrix(0,numofall,1) #point to value,..: values in 1,...,atomnum

componum<-numofall
parentLST<-matrix(0,componum,1)
level<-matrix(0,componum,1)
component<-matrix(0,componum,1)    

pinoComponent<-matrix(0,componum,1)   #pointer to component, level,...
pinoTaso<-matrix(0,componum,1)        #ordinal of level (pointer to levseq)

# Initilize the lists

AtomlistAtom[1:terminalnum]<-seq(1,terminalnum)
AtomlistNext[1:(terminalnum-1)]<-seq(2,terminalnum)
AtomlistNext[terminalnum]<-0
listEnd<-terminalnum
beg<-1

# Let us divide the lowest level set to disconnected parts

begi<-1
tobehandled<-matrix(0,nodenumOfTree,1)
atto<-AtomlistAtom[begi]
while (begi>0){
   if (value[atto]>0){
      node<-nodefinder[atto]
      tobehandled[node]<-1
   }    
   begi<-AtomlistNext[begi]
   atto<-AtomlistAtom[begi]
}
curterminalnum<-terminalnum

dld<-declevgen(tobehandled,curterminalnum,
left,right,val,vec,infopointer,parent,
low,upp,
d)
 
totbegSepary<-dld$totbegSepary
begsSepaNext<-dld$begsSepaNext
begsSepaBegs<-dld$begsSepaBegs
atomsSepaNext<-dld$atomsSepaNext
atomsSepaAtom<-dld$atomsSepaAtom

lc<-listchange(AtomlistAtom,AtomlistNext,totbegSepary,
begsSepaNext,begsSepaBegs,atomsSepaNext,atomsSepaAtom,
curterminalnum,beg)
begs<-lc$begs
AtomlistNext<-lc$AtomlistNext
AtomlistAtom<-lc$AtomlistAtom

koko<-length(begs)
# Talletetaan osat 
component[1:koko]<-begs
level[1:koko]<-levseq[1]       #arvo toistuu 
efek<-koko                     #kirjataan uusien osien lkm  ????? jos vain yksi
# Laitetaan kaikki osat pinoon
pinoComponent[1:koko]<-seq(1,koko)      #1,2,...,koko
pinoTaso[1:koko]<-1     #kaikki osat kuuluvat alimpaan tasojoukkoon
pinind<-koko            #indeksi pinoon

if (levnum>1){  while (pinind>=1){
  # Take from stack
  ind<-pinoComponent[pinind]      #indeksi tasoon
  levind<-pinoTaso[pinind]        #ko tason korkeus
  pinind<-pinind-1                #otettu pinosta
  partlevsetbeg<-component[ind]  
  higlev<-levseq[levind+1]
  
  # Make intersection with the curr. component and higher lev.set
  PrevlistEnd<-listEnd
  addnum<-0      #num of atoms in the intersection
  removenum<-0   #num of atoms which have to be removed to get intersec.
  runner<-partlevsetbeg
  origiListEnd<-listEnd
  while ((runner>0) && (runner<=origiListEnd)){
      atom<-AtomlistAtom[runner]
      arvo<-value[atom]
      if (arvo>=higlev){
          listEnd<-listEnd+1    
          AtomlistAtom[listEnd]<-atom
          AtomlistNext[listEnd]<-listEnd+1 
          addnum<-addnum+1     
      }
      else{           
          removenum<-removenum+1
      }                                
      runner<-AtomlistNext[runner] 
  }
  AtomlistNext[listEnd]<-0      # we have to correct the end to terminate
  if (addnum>0){
      AtomlistNext[PrevlistEnd]<-0
      beghigher<-PrevlistEnd+1 
  }
  if (removenum==0){  #jos leikkaus ei muuta, niin tasoj sailyy samana  
      level[ind]<-levseq[levind+1]  #remove lower part
          #component and parentLST stay same, it is enough to change level
      if (levind+1<levnum){ #jos ei olla korkeimmalla tasolla,laita pinoon
        pinoComponent[pinind+1]<-ind     
        pinoTaso[pinind+1]<-levind+1 #tasojouk taso on levind+1 
        pinind<-pinind+1       
      }
  }
  else if (addnum>0){     #leikkaus ei tyhja
      beg<-beghigher

      begi<-beghigher
      tobehandled<-matrix(0,nodenumOfTree,1)
      while (begi>0){
          atto<-AtomlistAtom[begi]
          node<-nodefinder[atto]
          tobehandled[node]<-1
          begi<-AtomlistNext[begi]
      }
      curterminalnum<-addnum

      dld<-declevgen(tobehandled,curterminalnum,
      left,right,val,vec,infopointer,parent,
      low,upp,
      d)
 
      totbegSepary<-dld$totbegSepary
      begsSepaNext<-dld$begsSepaNext
      begsSepaBegs<-dld$begsSepaBegs
      atomsSepaNext<-dld$atomsSepaNext
      atomsSepaAtom<-dld$atomsSepaAtom

#      apu2<-apu2+1
#if (apu2==1) an<-atomsSepaNext     

      lc<-listchange(AtomlistAtom,AtomlistNext,totbegSepary,
      begsSepaNext,begsSepaBegs,atomsSepaNext,atomsSepaAtom,
      curterminalnum,beg)
      begs<-lc$begs
      AtomlistNext<-lc$AtomlistNext
      AtomlistAtom<-lc$AtomlistAtom

      koko<-length(begs)    #jos vain yksi ?????????
      #
      # paivitetaan kumu tulokseen
      level[(efek+1):(efek+koko)]<-levseq[levind+1]   #arvo toistuu  
      parentLST[(efek+1):(efek+koko)]<-ind
      component[(efek+1):(efek+koko)]<-begs
      efek<-efek+koko
      if (levind+1<levnum){ #jos ei olla korkeimmalla tasolla,laita pinoon
        pinoComponent[(pinind+1):(pinind+koko)]<-seq(efek-koko+1,efek)
        pinoTaso[(pinind+1):(pinind+koko)]<-levind+1  #tasjouk tas on levind+1 
        pinind<-pinind+koko       
      }
  }
}} 
level<-t(level[1:efek])
parentLST<-t(parentLST[1:efek])
component<-t(component[1:efek])
#
return(list(level=level,parent=parentLST,
component=component,AtomlistAtom=AtomlistAtom,AtomlistNext=AtomlistNext))
}









decomdya<-function(numofall,atomnum,levseq,kg,N,nodenumOfDyaker){
#Makes density tree
#
#returns list(parent,level,component)
#  -component is pointer to AtomlistAtom, AtomlistNext, ei tarvita
#
d<-length(N)
levnum<-length(levseq)
#
AtomlistNext<-matrix(0,numofall,1)
AtomlistAtom<-matrix(0,numofall,1) #point to value,..: values in 1,...,atomnum
#
componum<-numofall
parent<-matrix(0,componum,1)
level<-matrix(0,componum,1)
component<-matrix(0,componum,1)    
#
pinoComponent<-matrix(0,componum,1)   #pointer to component, level,...
pinoTaso<-matrix(0,componum,1)        #ordinal of level (pointer to levseq)
#
# Initilize the lists
#
AtomlistAtom[1:atomnum]<-seq(1,atomnum)
AtomlistNext[1:(atomnum-1)]<-seq(2,atomnum)
AtomlistNext[atomnum]<-0
listEnd<-atomnum
#
# Let us divide the lowest level set to disconnected parts
#
beg<-1
terminalnum<-atomnum
dld<-declevdya(beg,AtomlistNext,AtomlistAtom,kg,N,nodenumOfDyaker,
terminalnum,d)  #terminalnum<-atomnum 
totbegSepary<-dld$totbegSepary
begsSepaNext<-dld$begsSepaNext
begsSepaBegs<-dld$begsSepaBegs
atomsSepaNext<-dld$atomsSepaNext
atomsSepaAtom<-dld$atomsSepaAtom
#
lc<-listchange(AtomlistAtom,AtomlistNext,totbegSepary,
begsSepaNext,begsSepaBegs,atomsSepaNext,atomsSepaAtom,
terminalnum,beg)
begs<-lc$begs
AtomlistNext<-lc$AtomlistNext
AtomlistAtom<-lc$AtomlistAtom
#
koko<-length(begs)
# Talletetaan osat 
component[1:koko]<-begs
level[1:koko]<-levseq[1]       #arvo toistuu 
efek<-koko                     #kirjataan uusien osien lkm  ????? jos vain yksi
# Laitetaan kaikki osat pinoon
pinoComponent[1:koko]<-seq(1,koko)      #1,2,...,koko
pinoTaso[1:koko]<-1     #kaikki osat kuuluvat alimpaan tasojoukkoon
pinind<-koko            #indeksi pinoon
# 
if (levnum>1){  while (pinind>=1){
  # Take from stack
  ind<-pinoComponent[pinind]      #indeksi tasoon
  levind<-pinoTaso[pinind]        #ko tason korkeus
  pinind<-pinind-1                #otettu pinosta
  partlevsetbeg<-component[ind]  
  higlev<-levseq[levind+1]
  #
  # Make intersection with the curr. component and higher lev.set
  PrevlistEnd<-listEnd
  addnum<-0      #num of atoms in the intersection
  removenum<-0   #num of atoms which have to be removed to get intersec.
  runner<-partlevsetbeg
  origiListEnd<-listEnd
  value<-kg$value
  while ((runner>0) && (runner<=origiListEnd)){
      atom<-AtomlistAtom[runner]
      arvo<-value[atom]
      if (arvo>=higlev){
          listEnd<-listEnd+1    
          AtomlistAtom[listEnd]<-atom
          AtomlistNext[listEnd]<-listEnd+1 
          addnum<-addnum+1     
      }
      else{           
          removenum<-removenum+1
      }                                
      runner<-AtomlistNext[runner] 
  }
  AtomlistNext[listEnd]<-0      # we have to correct the end to terminate
  if (addnum>0){
      AtomlistNext[PrevlistEnd]<-0
      beghigher<-PrevlistEnd+1 
  }
  if (removenum==0){  #jos leikkaus ei muuta, niin tasoj sailyy samana  
      level[ind]<-levseq[levind+1]  #remove lower part
          #component and parent stay same, it is enough to change level
      if (levind+1<levnum){ #jos ei olla korkeimmalla tasolla,laita pinoon
        pinoComponent[pinind+1]<-ind     
        pinoTaso[pinind+1]<-levind+1 #tasojouk taso on levind+1 
        pinind<-pinind+1       
      }
  }
  else if (addnum>0){     #leikkaus ei tyhja
      beg<-beghigher
      terminalnum<-addnum
      dld<-declevdya(beg,AtomlistNext,AtomlistAtom,kg,N,nodenumOfDyaker,
                     terminalnum,d) 
totbegSepary<-dld$totbegSepary
begsSepaNext<-dld$begsSepaNext
begsSepaBegs<-dld$begsSepaBegs
atomsSepaNext<-dld$atomsSepaNext
atomsSepaAtom<-dld$atomsSepaAtom
#
lc<-listchange(AtomlistAtom,AtomlistNext,totbegSepary,
begsSepaNext,begsSepaBegs,atomsSepaNext,atomsSepaAtom,
terminalnum,beg)
begs<-lc$begs
AtomlistNext<-lc$AtomlistNext
AtomlistAtom<-lc$AtomlistAtom
#
      koko<-length(begs)    #jos vain yksi ?????????
      #
      # paivitetaan kumu tulokseen
      level[(efek+1):(efek+koko)]<-levseq[levind+1]   #arvo toistuu  
      parent[(efek+1):(efek+koko)]<-ind
      component[(efek+1):(efek+koko)]<-begs
      efek<-efek+koko
      if (levind+1<levnum){ #jos ei olla korkeimmalla tasolla,laita pinoon
        pinoComponent[(pinind+1):(pinind+koko)]<-seq(efek-koko+1,efek)
        pinoTaso[(pinind+1):(pinind+koko)]<-levind+1  #tasjouk tas on levind+1 
        pinind<-pinind+koko       
      }
  }
}} 
level<-t(level[1:efek])
parent<-t(parent[1:efek])
component<-t(component[1:efek])
#
return(list(level=level,parent=parent,
component=component,AtomlistAtom=AtomlistAtom,AtomlistNext=AtomlistNext))
}









decom<-function(lsets,levels,links,alkublokki,blokki){
#Makes density tree,  edellyttaa jarjestyksen ???????
#
#lsets is levnum*atomnum-matrix
#levels is levnum-vector
#links is  atomnum*maxtouchnum-matrix, pointers to atoms,
#  for each atom we indicate which atoms it touches
#
#lsets matriisiin lisataan riveja, silla aikaisemmat rivit jakautuvat
#erillisiin osiinsa, lisataan levels:n vastaavat alkiot 
#
#Returns list(lsets,levels,parents)
# parents and levels are newlevnum-vectors
# lsets is newlevnum*atomnum
#
if (dim(t(lsets))[1]==1) levnum<-1 else levnum<-length(lsets[,1])
                                              #rows of lsets 
if (levnum==1) atomnum<-length(lsets) else
atomnum<-length(lsets[1,])     #maxalkio on n
newlevnum<-levnum*atomnum       #karkea arvio, jokainen tasojoukko 
#                               #voi periaatteessa jakautua n:aan osaan
newlsets<-matrix(0,alkublokki,atomnum) 
newlevels<-matrix(0,alkublokki,1)
parents<-matrix(0,alkublokki,1)
#
curblokki<-alkublokki
#
pino<-matrix(0,newlevnum,2) #1.col indeksi newlsets:iin, 2.col ind tasoon
a<-1
b<-2
#
if (levnum==1) levset<-lsets else
levset<-lsets[1,]                   #alin tasojoukko
rindeksit<-change(levset)            #change the representation
kumu<-declev(rindeksit,links,atomnum)  #jaetaan alin tasoj. osiin
if (dim(t(kumu))[1]==1) koko<-1 else koko<-length(kumu[,1]) #osien lkm
# Talletetaan osat 
newlsets[1:koko,]<-kumu   
newlevels[1:koko]<-levels[1]     #arvo toistuu 
efek<-koko                       #kirjataan uusien osien lkm
# Laitetaan kaikki osat pinoon
pino[1:koko,a]<-seq(1,koko)      #1,2,...,koko
pino[1:koko,b]<-1   #kaikki osat kuuluvat alimpaan tasojoukkoon
pinind<-koko        #indeksi pinoon
# 
if (levnum>1){  while (pinind>=1){
  ind<-pino[pinind,a]         #indeksi tasoon
  levind<-pino[pinind,b]      #ko tason korkeus
  pinind<-pinind-1            #otettu pinosta
  partlevset<-newlsets[ind,]
  higlevset<-lsets[levind+1,] #huom levind<levnum
  levset<-partlevset*higlevset
  if (sum(partlevset-levset)==0){  
          #jos leikkaus ei muuta, niin tasoj sailyy samana  
      newlevels[ind]<-levels[levind+1]  #poistetaan alempi osa      
      if (levind+1<levnum){ #jos ei olla korkeimmalla tasolla,laita pinoon
        pino[pinind+1,a]<-ind     
        pino[pinind+1,b]<-levind+1 #tasojouk taso on levind+1 
        pinind<-pinind+1       
      }
  }
  else if (sum(levset)>0){   #leikkaus ei tyhja
      rindeksit<-change(levset)
      kumu<-declev(rindeksit,links,atomnum) #jaet tasoj. osa osiin
      if (dim(t(kumu))[1]==1) koko<-1 else koko<-length(kumu[,1]) #osien lkm
      if ((efek+koko)>curblokki){   
        newlsets<-blokitus(newlsets,blokki)
        newlevels<-blokitus(newlevels,blokki)
        parents<-blokitus(parents,blokki)
        curblokki<-curblokki+blokki    
      }
      newlsets[(efek+1):(efek+koko),]<-kumu  #paivitetaan kumu tulokseen
      newlevels[(efek+1):(efek+koko),]<-levels[levind+1]   #arvo toistuu  
      parents[(efek+1):(efek+koko),]<-ind
      efek<-efek+koko
      if (levind+1<levnum){ #jos ei olla korkeimmalla tasolla,laita pinoon
        pino[(pinind+1):(pinind+koko),a]<-seq(efek-koko+1,efek)
        pino[(pinind+1):(pinind+koko),b]<-levind+1 #tasojouk taso on levind+1 
        pinind<-pinind+koko       
      }
  }
}} 
newlevels<-t(newlevels[1:efek])
newlsets<-newlsets[1:efek,]
parents<-t(parents[1:efek])
return(list(lsets=newlsets,levels=newlevels,parents=parents))
}








den2reg<-function(dendat,binlkm,kantaja)
{
#muuntaa tiheysdatan regressiodataksi

#dendat on tiheysdatan sisaltava n*xlkm matriisi
#binlkm on niitten lokeroitten maara joihin yksi muuttuja ositetaan
#otosavaruus ositetaan binlkm^p lokeroon
#kantaja on 2*xlkm vaakavektori, sisaltaa kantajan kullekin 
#muuttujalle, olet etta kaikki dendat:n hav todella sisaltyvat kantajaan.

#palauttaa: listan vast
#vast.dep on saatu*1 vektori, sisaltaa frekvenssit,
#(saatu on erillisten diskretoitujen havaintojen lkm) 
#vast.ind on saatu*xlkm matriisi, sisaltaa niitten lokeroitten 
#keskipisteet joita (diskretoidussa) datassa esiintyy vahintaan yksi, 
#vast.hila on xlkm*3 matriisi, 
#vast.hila:n i:s rivi sis. i:nnelle muuttujalle 
#pisteiden maaran
#ensimmaisen regressiodatan havaintopisteen,
#viimeisen regressiodatan havaintopisteen.

xlkm<-length(dendat[1,]) #dendat:in sarakkeitten lkm on muuttujien lkm
n<-length(dendat[,1])    #dendat:in rivien lkm on havaintojen maara
hila<-matrix(1,xlkm,3)   #hila on xlkm*3 matriisi
binhila<-hila            #binhila on xlkm*3 matriisi
valpit<-matrix(1,xlkm,1)      #hilan valien pituudet
hila[,1]<-binlkm*hila[,1]
binhila[,1]<-binlkm*binhila[,1]
i<-1
while (i<=xlkm){
     binhila[i,2]<-kantaja[i,1]   #min(dendat[,i])-epsi 
     binhila[i,3]<-kantaja[i,2]     #max(dendat[,i])+epsi 
     valpit[i]<-(binhila[i,3]-binhila[i,2])/binlkm
       #binhila:n i:s rivi sis. i:nnelle muuttujalle 
       #lokeroinnin alkupisteen, arvoalueen loppupisteen   
       #valpit: arvoalueen pituus jaettuna lokeroitten lkm:lla
       #eli yhden lokeron leveys. 
     i<-i+1
}
hila[,2]<-binhila[,2]+valpit/2
hila[,3]<-binhila[,3]-valpit/2
       #hila:n i:s rivi sis. i:nnelle muuttujalle 
       #ensimmaisen regressiodatan havaintopisteen,
       #viimeisen regressiodatan havaintopisteen
#if (valpit<=0) stop("in some variable there is no variation")
hiladat<-matrix(1,n,xlkm) #muunnetaan dendat hiladat:iksi
                          #ts. pyoristetaan havainnot 
                          #hiladat sis. diskretoidut havainnot
i<-1
while (i<=n){       #kaydaan lapi aineisto
    #pyoristetaan i:s havainto hilapisteeseen
    j<-1
    while (j<=xlkm){
       alavali<-floor((dendat[i,j]-binhila[j,2])/valpit[j])
           #alavali ilmaisee monennessako lokerossa hav. sijaitsee
       hiladat[i,j]<-binhila[j,2]+alavali*valpit[j]+valpit[j]/2
       j<-j+1
    }
i<-i+1
}
xtulos<-matrix(0,n,xlkm) #periaatteessa mahdollista etta kaikki n
                         #havaintoa ovat eri lokeroissa, siksi
                         #laitetaan xtulos matriisin rivien maaraksi n
ytulos<-matrix(0,n,1)
xtulos[1,]<-hiladat[1,]  #hiladat:in ensimmainen rivi esiintyy ainakin kerran
ytulos[1]<-1             #sen frekvenssi ainakin yksi
saatu<-1                 #toistaiseksi yksi erillinen havainto
i<-1
while (i<n){  #kaydaan lapi aineisto
   i<-i+1     #aloitetaan kakkosesta
   lippu<-0   #apriori kyseessa uusi lajityyppi
   j<-1
   while ((j<=saatu) && (lippu==0)){  #kaydaan lapi keratyt havinnot
       if (all(hiladat[i,]==xtulos[j,])){  #jos on jo saatu
            lippu<-1     #liputetaan etta havaittiin toisto
            jind<-j      #merkataan indeksi frekvenssin paivitysta varten
       }
       j<-j+1       
   }
   if (lippu==1) ytulos[jind]<-ytulos[jind]+1 
            #jos saatiin toisto, paivitetaan frekvenssi 
      else{ 
         saatu<-saatu+1      #jos saatiin uusi, lisataan saatu:un yksi ja
         xtulos[saatu,]<-hiladat[i,]  #merkitaan uusi lajityyppi muistiin
         ytulos[saatu]<-1    #uuden lajityypin frekvenssi on aluksi yksi
      }
}
xtulos<-xtulos[1:saatu,]
ytulos<-ytulos[1:saatu]
ytulos<-t(t(ytulos))
if (xlkm==1) xtulos<-t(t(xtulos))
return(list(dep=ytulos,ind=xtulos,hila=hila))
}

dend2parent<-function(hc,dendat)
{
n<-dim(dendat)[1]
d<-dim(dendat)[2]
nodenum<-length(hc$height)+n
parent<-matrix(0,nodenum,1)
volume<-matrix(0,nodenum,1)
center<-matrix(0,d,nodenum)
level<-matrix(0,nodenum,1)
level[(n+1):nodenum]<-hc$height
pointers<-matrix(0,n,1)      #pointers dendat to tree 

joinnum<-length(hc$height)
lkm<-matrix(0,joinnum,1)
vec1<-matrix(0,1,d)
vec2<-matrix(0,1,d)
v1<-0
v2<-0
vapaa<-1
for (i in 1:joinnum){
   node1<-hc$merge[i,1]
   node2<-hc$merge[i,2]
   if (node1<0){
        parent[vapaa]<-i+n
        for (j in 1:d) vec1[j]<-dendat[-node1,j]
        v1<-1
        center[,vapaa]<-vec1
        volume[vapaa]<-v1
        pointers[-node1]<-vapaa
        lkm1<-1
        vapaa<-vapaa+1
   }
   else{
        parent[node1+n]<-i+n
        vec1<-center[,node1+n]
        v1<-volume[node1+n]
        lkm1<-lkm[node1]
   }
   if (node2<0){
        parent[vapaa]<-i+n
        for (j in 1:d) vec2[j]<-dendat[-node2,j]
        v2<-1
        center[,vapaa]<-vec2
        volume[vapaa]<-v2
        pointers[-node2]<-vapaa
        lkm2<-1
        vapaa<-vapaa+1
   }
   else{
        parent[node2+n]<-i+n
        vec2<-center[,node2+n]
        v2<-volume[node2+n]
        lkm2<-lkm[node2]
   }
   volume[i+n]<-1.1*(v1+v2)
   center[,i+n]<-(lkm1*vec1+lkm2*vec2)/(lkm1+lkm2)
   lkm[i]<-lkm1+lkm2
}

apoin<-matrix(0,n,1)
for (i in 1:n) apoin[i]<-nodenum-pointers[i]+1
apar<-parent[nodenum:1]
apar2<-matrix(0,n,1)
for (i in 1:nodenum) if (apar[i]!=0) apar2[i]<-nodenum-apar[i]+1

return(list(parent=apar2,level=level[nodenum:1],
volume=volume[nodenum:1],center=center[,nodenum:1],pointers=apoin))
}


depth2com<-function(dep,N){
#
d<-length(N)
logn<-log(N,base=2)
cusu<-cumsum(logn)
ind<-1
while ((ind<=d) && ((dep-cusu[ind])>0)){
  ind<-ind+1
}
direc<-min(ind,d)
if (direc==1){
  depind<-dep
}
else{
  depind<-dep-cusu[direc-1]
}
return(list(direc=direc,depind=depind))
}
depth<-function(mt){
#finds the dephts of the nodes
#
#mt is a result from multitree or pruneprof
#
roots<-mt$roots
child<-mt$child
sibling<-mt$sibling
#
itemnum<-length(child)
depths<-matrix(0,itemnum,1)
#
rootnum<-length(roots)
#
for (i in 1:rootnum){
    pino<-matrix(0,itemnum,1)
    pino[1]<-roots[i]  
    pinin<-1
    depths[roots[i]]<-1
    while (pinin>0){
        cur<-pino[pinin]      #take from stack
        pinin<-pinin-1
        if (sibling[cur]>0){    #put right to stack
             pinin<-pinin+1
             pino[pinin]<-sibling[cur]
             depths[sibling[cur]]<-depths[cur]
        }
        while (child[cur]>0){    #go to leaf and put right nodes to stack
             chi<-child[cur]
             depths[chi]<-depths[cur]+1
             if (sibling[chi]>0){ 
                   pinin<-pinin+1
                   pino[pinin]<-sibling[chi]
                   depths[sibling[chi]]<-depths[cur]+1
             }
             cur<-chi
        }
    }
}
return(depths)
}







digit<-function(luku,base){
#Gives representation of luku for system with base
#
#luku is a natural number >=0
#base is d-vector of integers >=2, d>=2, 
#base[d] tarvitaan vain tarkistamaan onko luku rajoissa
#
#Returns d-vector of integers.
#
#example: digit(52,c(10,10)), returns vector (2,5)
#
d<-length(base)
digi<-matrix(0,d,1)
jako<-matrix(0,d,1)
jako[d]<-base[1]
for (i in (d-1):1){
  jako[i]<-base[d-i+1]*jako[i+1]
}
vah<-0
for (i in 1:(d-1)){
  digi[i]<-floor((luku-vah)/jako[i+1]) #if digi[i]>base[i], then ERROR
  vah<-vah+digi[i]*jako[i+1]
}
digi[d]<-luku-vah
# annetaan vastaus kaanteisesti se 2354 annetaan c(4,5,3,2)
# talloin vastaavuus sailyy base:n kanssa 
#apu<-matrix(0,d,1)
#for (i in 1:d){
#  apu[i]<-digi[d-i+1]
#}
apu<-digi[d:1]
return(apu)
}
dist.func<-function(dendat,xepsi=0,yepsi=0,col="black",type="distr",
log="y",cex.axis=1)
{
n<-length(dendat)

if (type=="distr"){

plot(x="",y="",
xlim=c(min(dendat)-xepsi,max(dendat)+xepsi), ylim=c(0-yepsi,1+yepsi),
xlab="",ylab="",cex.axis=cex.axis)
ycur<-0
ordi<-order(dendat)
dendatord<-dendat[ordi]
for(i in 1:(n-1)){
    segments(dendatord[i],ycur,dendatord[i],ycur+1/n,col=col)
    segments(dendatord[i],ycur+1/n,dendatord[i+1],ycur+1/n,col=col)
    ycur<-ycur+1/n
}
segments(dendatord[n],ycur,dendatord[n],ycur+1/n,col=col)
segments(dendatord[n],ycur+1/n,max(dendat)+xepsi,ycur+1/n,col=col)

}
else if ((type=="right.tail") || (type=="left.tail")){

  if (type=="right.tail"){
         redu.ind<-(dendat>0) 
         dendat.redu<-dendat[redu.ind]
  }
  else{
         redu.ind<-(dendat<0)
         dendat.redu<--dendat[redu.ind]
  }
  ordi<-order(dendat.redu)
  dendat.ord<-dendat.redu[ordi]
  nredu<-length(dendat.redu)
  level<-seq(nredu,1)
  plot(dendat.ord,level,log=log,xlab="",ylab="",cex.axis=cex.axis)

  #ordi<-order(dendat)
  #dendat.ord<-dendat[ordi]
  #medi.ind<-floor(n/2)
  #dendat.redu<-dendat.ord[medi.ind:n]
  #nredu<-length(dendat.redu)
  #level<-seq(nredu,1)
  #plot(dendat.redu,level,log="y",xlab="",ylab="")

}

}

dotouchgen<-function(indelow1,indeupp1,indelow2,indeupp2,direction){
#
epsi<-0
d<-length(indelow1)
touch<-TRUE
i<-1
while (i<=d){
     if ((i != direction) &&
         ((indelow1[i]>indeupp2[i]+epsi) || (indeupp1[i]<indelow2[i]-epsi))){
              touch<-FALSE
     }
     i<-i+1
}
return(touch)
}
dotouch<-function(inde1,inde2,direction){
#
d<-length(inde1)
touch<-TRUE
for (i in direction:d){
     if ((inde1[i]>inde2[i]+1) || (inde1[i]<inde2[i]-1)){
           touch<-FALSE
     }
}
return(touch)
}
drawgene<-function(values,recs,plkm=60,ep1=0.5){
#Makes data for drawing a perspective plot.

#plkm on kuvaajan hilan pisteiden lkm
#ep1 makes 0-corona around the support (useful for densities)

#koe<-drawgene(values,recs,plkm=30)
#persp(koe$x,koe$y,koe$z,phi=30,theta=60) 

alkux<-min(recs[,1])-ep1
alkuy<-min(recs[,3])-ep1
loppux<-max(recs[,2])+ep1
loppuy<-max(recs[,4])+ep1
pitx<-(loppux-alkux)/plkm
pity<-(loppuy-alkuy)/plkm
x<-alkux+c(0:plkm)*pitx
y<-alkuy+c(0:plkm)*pity

reclkm<-length(values)
xdim<-length(x)
ydim<-length(y)
arvot<-matrix(0,xdim,ydim)

l<-1
while (l<=reclkm){
   begx<-recs[l,1]
   endx<-recs[l,2]
   begy<-recs[l,3]
   endy<-recs[l,4]

   begxind<-round(plkm*(begx-alkux)/(loppux-alkux))
   endxind<-round(plkm*(endx-alkux)/(loppux-alkux))
   begyind<-round(plkm*(begy-alkuy)/(loppuy-alkuy))
   endyind<-round(plkm*(endy-alkuy)/(loppuy-alkuy))

   arvot[begxind:endxind,begyind:endyind]<-values[l]

   l<-l+1
}

return(list(x=x,y=y,z=arvot))
#persp(x,y,arvot)
}










drawhist<-function(dendat,binlkm,epsi=0,plkm){
#piirtaa 2-ulotteisessa tapauksessa histogramma estimaattorin kuvaajan 
#
#plkm on kuvaajan hilan pisteiden lkm
#
#dendat<-matrix(rnorm(20),10) 
#koe<-drawhist(dendat,binlkm=3,plk=30)
#persp(koe$x,koe$y,koe$z,phi=30,theta=60)
#
hi<-histo(dendat,binlkm,epsi)
recs<-hi$recs
values<-hi$values   
#
ans<-drawgene(values,recs,plkm)
return(list(x=ans$x,y=ans$y,z=ans$z))
}                                      








draw.kern<-function(value,index,N,support,minval=0,dendat=NULL,h=NULL)
{

d<-length(N)

if (d==2){

x<-matrix(0,N[1]+2,1)
y<-matrix(0,N[2]+2,1)
z<-matrix(minval,N[1]+2,N[2]+2)
#col<-matrix("black",dim(z)[1]*dim(z)[2],1)

minim<-matrix(0,d,1)  #minim is d-vector of minimums
maxim<-matrix(0,d,1)
for (i in 1:d){
  minim[i]<-support[2*i-1]
  maxim[i]<-support[2*i]
}
delta<-(maxim-minim)/(N+1)

indenum<-dim(index)[1]

i<-1
while (i<=indenum){
   inde<-index[i,]
   z[1+inde[1],1+inde[2]]<-value[i]
   #col[1+inde[1]+dim(z)[1]*inde[2]]<-ts[i]
   i<-i+1
}

i<-1
while (i<=N[1]){
   x[1+i]<-support[1]+delta[1]*i
   i<-i+1
}

i<-1
while (i<=N[2]){
   y[1+i]<-support[3]+delta[2]*i
   i<-i+1
}

x[1]<-support[1]
x[N[1]+2]<-support[2]
y[1]<-support[3]
y[N[2]+2]<-support[4]

return(list(x=x,y=y,z=z)) #col=col[length(col):1]))

}

else{    #d=1

x<-matrix(0,N+2,1)
y<-matrix(0,N+2,1)

minim<-min(dendat)
maxim<-max(dendat)
hmax<-max(h)
delta<-(maxim-minim+2*hmax)/(N+1)

indenum<-dim(index)[1]

i<-1
while (i<=indenum){

   inde<-index[i]
   point<-minim-hmax+delta*inde
    
   y[1+inde]<-value[i]
   x[1+inde]<-point

   i<-i+1
}
x[1]<-minim-hmax
x[N+2]<-minim-hmax+delta*N+delta

return(list(x=x,y=y))

}

}











draw.levset<-function(pcf,lev=NULL,bary=NULL,propor=0.1,col=NULL,
bound=NULL,dendat=NULL,xaxt="s",yaxt="s",cex.axis=1)
{

if (is.null(lev)) lev<-propor*max(pcf$value)

d<-length(pcf$N)
step<-matrix(0,d,1)
for (i in 1:d) step[i]=(pcf$support[2*i]-pcf$support[2*i-1])/pcf$N[i];

if (is.null(bound)){
  xmin<-pcf$support[1]
  xmax<-pcf$support[2]
  ymin<-pcf$support[3]
  ymax<-pcf$support[4]
}
else{
  xmin<-bound[1]
  xmax<-bound[2]
  ymin<-bound[3]
  ymax<-bound[4]
}

if (is.null(bary))
   plot(xmin,ymin,type="n",xlab="",ylab="",xlim=c(xmin,xmax),ylim=c(ymin,ymax),
   pch=20,col="red",xaxt=xaxt,yaxt=yaxt,cex.axis=cex.axis)
else
  plot(x=bary[1],y=bary[2],
  xlab="",ylab="",xlim=c(xmin,xmax),ylim=c(ymin,ymax),
  pch=20,col="red",xaxt=xaxt,yaxt=yaxt,cex.axis=cex.axis)

lenni<-length(pcf$value)
for (i in 1:lenni){
  if (pcf$value[i]>=lev){

     x1<-pcf$support[1]+step[1]*pcf$down[i,1]
     x2<-pcf$support[1]+step[1]*pcf$high[i,1] 
     y1<-pcf$support[3]+step[2]*pcf$down[i,2]
     y2<-pcf$support[3]+step[2]*pcf$high[i,2] 

     if (is.null(col)) polygon(c(x1,x2,x2,x1),c(y1,y1,y2,y2))  
     else  polygon(c(x1,x2,x2,x1),c(y1,y1,y2,y2),col=col[i],lty="blank")
  }
  i<-i+1
}

if (!is.null(dendat)) points(dendat)

#points(x=bary[1],y=bary[2],pch=20,col="red")

}



draw.pcf<-function(pcf,pnum=rep(32,length(pcf$N)),corona=5,dens=FALSE,minval=0,
drawkern=TRUE)
{
#Makes data for drawing a perspective plot.
#pnum on kuvaajan hilan pisteiden lkm
#corona makes corona around the support (useful for densities)

d<-length(pcf$N)

if (d==2){

#col=matrix("black",length(pcf$value),1)

step<-matrix(0,d,1)
for (i in 1:d){
   step[i]<-(pcf$support[2*i]-pcf$support[2*i-1])/pcf$N[i]
}

if ((drawkern)&&(!is.null(pcf$index))){
   return(draw.kern(pcf$value,pcf$index,pcf$N,pcf$support,minval=minval))
}

else{
     pit<-matrix(0,d,1)
     for (i in 1:d){
         pit[i]<-(pcf$support[2*i]-pcf$support[2*i-1])/pnum[i]
     }
     alkux<-pcf$support[1]+pit[1]/2-corona*pit[1]
     alkuy<-pcf$support[3]+pit[2]/2-corona*pit[2]
     loppux<-pcf$support[2]-pit[1]/2+corona*pit[1]
     loppuy<-pcf$support[4]-pit[2]/2+corona*pit[2]

     pnum2<-pnum+2*corona
     x<-alkux+c(0:(pnum2[1]-1))*pit[1]
     y<-alkuy+c(0:(pnum2[2]-1))*pit[2]

     reclkm<-length(pcf$value)
     xdim<-length(x)
     ydim<-length(y)
     arvot<-matrix(minval,xdim,ydim)

     l<-1
     while (l<=reclkm){
         begx<-pcf$support[1]+step[1]*(pcf$down[l,1])   #recs[l,1]
         endx<-pcf$support[1]+step[1]*(pcf$high[l,1])     #recs[l,2]
         begy<-pcf$support[3]+step[2]*(pcf$down[l,2])   #recs[l,3]
         endy<-pcf$support[3]+step[2]*(pcf$high[l,2])     #recs[l,4]

         begxind<-round(pnum2[1]*(begx-alkux)/(loppux-alkux))
         endxind<-round(pnum2[1]*(endx-alkux)/(loppux-alkux))
         begyind<-round(pnum2[2]*(begy-alkuy)/(loppuy-alkuy))
         endyind<-round(pnum2[2]*(endy-alkuy)/(loppuy-alkuy))

         arvot[begxind:endxind,begyind:endyind]<-pcf$value[l]
         #col[(begxind+(ydim-1)*begxind):(endxind+(ydim-1)*endyind)]<-ts[l]

         l<-l+1
     }

     #return(apu)
     return(list(x=x,y=y,z=arvot))
}  # else

}  # if (d==2)

else{  #d==1

if (dens){ 
  N<-pcf$N+2 
  alku<-1
}
else{
  N<-pcf$N
  alku<-0
}

x<-matrix(0,N,1)
y<-matrix(0,N,1)
step<-(pcf$support[2]-pcf$support[1])/pcf$N
minim<-pcf$support[1]
maxim<-pcf$support[2]
indenum<-length(pcf$value)

i<-1
while (i<=indenum){

   inde<-pcf$high[i]
   point<-minim+step*inde-step/2
    
   y[alku+inde]<-pcf$value[i]
   x[alku+inde]<-point

   i<-i+1
}

if (dens){
  x[1]<-minim-step/2
  x[N]<-maxim+step/2
}

# remove zeros
if (dens){
  numposi<-0
  for (i in 1:length(y)){
    if (y[i]>0){
       numposi<-numposi+1
       y[numposi]<-y[i]
       x[numposi]<-x[i]
    }
  }
  x<-x[1:numposi]
  y<-y[1:numposi]
}

or<-order(x)
xor<-x[or]
yor<-y[or]

return(list(x=xor,y=yor))

}  # else d=1

}











epane<-function(x,h){
#
d<-length(x)
val<-1
for (i in 1:d){
   val<-val*3*(1-(x[i]/h)^2)/2
}
return(val)
}
epan<-function(x)
{
d<-length(x)
val<-1
for (i in 1:d){
   val<-val*3*(1-x[i]^2)/2
}
return(val)
}
etais<-function(x,y){
#laskee euklid etais nelion vektorien x ja y valilla
#
pit<-length(x)
vast<-0
i<-1
while (i<=pit){
  vast<-vast+(x[i]-y[i])^2
  i<-i+1
}
return(vast)
}
etaisrec<-function(point,rec)
{
# calculates the squared diatance of a point to a rectangle

d<-length(rec)/2

res<-0
for (i in 1:d){
   if (point[i]>rec[2*i]) res<-res+(point[i]-rec[2*i])^2
   else if (point[i]<rec[2*i-1]) res<-res+(point[i]-rec[2*i-1])^2
}

return(res)

}



eva.clayton<-function(x,t,marginal="unif",sig=c(1,1),df=1)
# t>0
{
u<-x[1]
v<-x[2]
marg1<-1
marg2<-1

if (marginal=="normal"){
   u<-pnorm(x[1]/sig[1])
   v<-pnorm(x[2]/sig[2])
   marg1<-evanor(x[1]/sig[1])/sig[1]
   marg2<-evanor(x[2]/sig[2])/sig[2]
}
if (marginal=="student"){
   u<-pt(x[1],df)
   v<-pt(x[2],df)
   marg1<-dt(x[1],df)
   marg2<-dt(x[2],df)
}

val<-(1+t)*(u*v)^(-1-t)*(u^(-t)+v^(-t)-1)^(-2-1/t)*marg1*marg2

#if (val<0) val<-0

return(val)
}

eva.cop6<-function(x,t,marginal="unif",sig=c(1,1))
# t in [1,\infty)
{
u<-x[1]
v<-x[2]
marg1<-1
marg2<-1

if (marginal=="normal"){
   u<-pnorm(x[1]/sig[1])
   v<-pnorm(x[2]/sig[2])
   marg1<-evanor(x[1]/sig[2])/sig[1]
   marg2<-evanor(x[2]/sig[2])/sig[2]
}

val<-t*(1-u)^(t-1)*(1-v)^(t-1)*
((1-u)^t+(1-v)^t-(1-u)^t*(1-v)^t)^(1/t-2)*
(-(1/t-1)*(1-(1-u)^t)*(1-(1-v)^t)+
 (1-u)^t+(1-v)^t-(1-u)^t*(1-v)^t)*marg1*marg2

#if (val<0) val<-0

return(val)
}

eva.copula<-function(x,type="gauss",marginal="unif",sig=rep(1,length(x)),r=0,
t=rep(4,length(x)),g=1)
{
# sig is std of marginals, r is the correlation coeff, 
# t is deg of freedom

d<-length(x)
marg<-matrix(0,d,1)
u<-matrix(0,d,1)

if (marginal=="unif"){
   for (i in 1:d){
      u[i]<-x[i]/sig[i]  #+1/2
      marg[i]<-1/sig[i]
   }
}
if ((marginal=="normal")||(marginal=="gauss")){
   for (i in 1:d){
      u[i]<-pnorm(x[i]/sig[i])
      marg[i]<-evanor(x[i]/sig[i])/sig[i]
   }
}
if (marginal=="student"){
   for (i in 1:d){
      u[i]<-pt(x[i]/sig[i],df=t[i])
      marg[i]<-dt(x[i]/sig[i],df=t[i])/sig[i]
   }
}
if (type=="gauss"){
   d<-2
   x1<-qnorm(u[1],sd=1)
   x2<-qnorm(u[2],sd=1)

#   produ<-dnorm(x1,sd=1)*dnorm(x2,sd=1)
#   nelio<-(x1^2+x2^2-2*r*x1*x2)/(1-r^2)
#   vakio<-(2*pi)^(-d/2) 
#   g<-vakio*(1-r^2)^(-1/2)*exp(-(1/2)*nelio)
#   val<-g/produ*marg[1]*marg[2]

  copuval<-(1-r^2)^(-1/2)*
  exp(-(x1^2+x2^2-2*r*x1*x2)/(2*(1-r^2)))/exp(-(x1^2+x2^2)/2)
  val<-copuval*marg[1]*marg[2]

}
if (type=="gumbel"){
  link<-function(y,g){ return ( (-log(y))^g ) }
  linkinv<-function(y,g){ return ( exp(-y^(1/g)) ) }
  der1<-function(y,g){ return ( -g*(-log(y))^(g-1)/y ) }
  der2<-function(y,g){ return ( g*y^(-2)*(-log(y))^(g-2)*(g-1-log(y)) ) }
  
  linky<-link(u,g)
  a<-sum(linky)
  b<-linkinv(a,g)
  der1b<-der1(b,g)
  der2b<-der2(b,g)
  psi<--der2b*der1b^(-3)
  deriy<-der1(u,g) 
  val<-psi*abs(prod(deriy))*prod(marg)
}
if (type=="frank"){
  link<-function(y,g){ return ( -log((exp(-g*y)-1)/(exp(-g)-1)) ) }
  linkinv<-function(y,g){ return ( -log(1+(exp(-g)-1)/exp(y))/g  ) }
  der1<-function(y,g){ return ( g*exp(-g*y)/(exp(-g*y)-1) ) }
  der2<-function(y,g){ return ( g^2*exp(-g*y)/(exp(-g*y)-1)^2 ) }
  
  linky<-link(u,g)
  a<-sum(linky)
  b<-linkinv(a,g)
  der1b<-der1(b,g)
  der2b<-der2(b,g)
  psi<--der2b*der1b^(-3)
  deriy<-der1(u,g) 
  val<-psi*abs(prod(deriy))*prod(marg)
}
if (type=="clayton"){
  link<-function(y,g){ return ( y^(-g)-1 ) }
  linkinv<-function(y,g){ return ( (y+1)^(-1/g) ) }
  der1<-function(y,g){ return ( -g*y^(-g-1) ) }
  der2<-function(y,g){ return ( g*(g+1)*y^(-g-2) ) }
  
  linky<-link(u,g)
  a<-sum(linky)
  b<-linkinv(a,g)
  der1b<-der1(b,g)
  der2b<-der2(b,g)
  psi<--der2b*der1b^(-3)
  deriy<-der1(u,g) 
  val<-psi*abs(prod(deriy))*prod(marg)
}

return(val)
}






eva.gauss<-function(x,t=1,marginal="unif",sig=c(1,1),r=0,tapa1=TRUE)
{
#  sig is std of marginals

if (marginal=="unif"){
   u<-x[1]/sig[1]+1/2
   v<-x[2]/sig[2]+1/2
   marg1<-1/sig[1]
   marg2<-1/sig[2]
}
if (marginal=="normal"){
   u<-pnorm(x[1]/sig[1])
   v<-pnorm(x[2]/sig[2])
   marg1<-evanor(x[1]/sig[1])/sig[1]
   marg2<-evanor(x[2]/sig[2])/sig[2]
}
if (marginal=="student"){
   u<-pt(x[1]/sig[1],df=t)
   v<-pt(x[2]/sig[2],df=t)
   marg1<-dt(x[1]/sig[1],df=t)/sig[1]
   marg2<-dt(x[2]/sig[2],df=t)/sig[2]
}

d<-2
x1<-qnorm(u,sd=1)
x2<-qnorm(v,sd=1)

if (tapa1){
  produ<-dnorm(x1,sd=1)*dnorm(x2,sd=1)
  nelio<-(x1^2+x2^2-2*r*x1*x2)/(1-r^2)
  vakio<-(2*pi)^(-d/2) 
  g<-vakio*(1-r^2)^(-1/2)*exp(-(1/2)*nelio)
  val<-g/produ*marg1*marg2
}
else{
  # x1,x2 -> copuval
  copuval<-(1-r^2)^(-1/2)*
  exp(-(x1^2+x2^2-2*r*x1*x2)/(2*(1-r^2)))/exp(-(x1^2+x2^2)/2)
  val<-copuval*marg1*marg2
}

return(val)
}

eva.hat<-function(x,a=0.5,b=0.5)
{
# 0<a<1, b<1
# if b<a then marginal is unimodal
# if a^2 < b < a then not star unimodal

d<-length(x)
eta<-sum(x^2)     #vektorin x pituuden nelio
normvakio<-((2*pi)^d*(a^(-d)-b))^(-1)
tulos<-normvakio*(exp(-a^2*eta/2)-b*exp(-eta/2))

return(tulos)
}
eval.func.1D<-function(func,N,support=NULL,g=1,std=1,distr=FALSE,
M=NULL,sig=NULL,p=NULL,a=0.5,b=0.5,d=2)
{
if (func=="gauss"){
   norma<-(2*pi)^(-1/2)
   funni<-function(t){ fu<-exp(-t^2/2); return( norma*fu ) }
}
if (func=="polynomial"){
   support<-c(-std,std)
   norma<-(2*(1-1/(g+1)))^(-1)
   funni<-function(t){ fu<-1-abs(t)^g; return( norma*fu ) }
}
if (func=="student"){
   norma<-gamma((g+1)/2)/((g*pi)^(1/2)*gamma(g/2))
   funni<-function(t){ fu<-(1+t^2/g)^(-(g+1)/2); return( norma*fu ) }
   #y<-dt(x,df=g)
}
if (func=="exponential"){
   norma<-1/2
   funni<-function(t){ fu<-exp(-abs(t)); return( norma*fu ) }
}
if (func=="exponential"){
   norma<-1/2
   funni<-function(t){ fu<-exp(-abs(t)); return( norma*fu ) }
}
if (func=="mixt"){
   funni<-function(t){ 
       mixnum<-length(p)
       val<-0
       for (mi in 1:mixnum){
               evapoint<-(t-M[mi])/sig[mi]
               val<-val+p[mi]*evanor(evapoint)/sig[mi]
        }
        return( val ) 
   }
}
if (func=="hat"){
   normavak<-((2*pi)^d*(a^(-d)-b))^(-1)
   norma<-normavak*(2*pi)^((d-1)/2)
   funni<-function(t){  #(t,a,b,d,...){ 
          fu<-a^(1-d)*exp(-a^2*t^2)-b*exp(-t^2/2); return( norma*fu ) }
}

if (is.null(support)) support<-c(-1,1)

value<-matrix(0,N,1)
step<-(support[2]-support[1])/N
lowsuppo<-support[1]

if (!distr){
   for (i in 1:N){
       inde<-i
       t<-lowsuppo+step*inde-step/2
       value[i]<-funni(t/std)/std
   }
}
else{
   inde<-1
   t<-lowsuppo+step*inde-step/2
   value[1]<-step*funni(t/std)/std
   for (i in 2:N){
       inde<-i
       t<-lowsuppo+step*inde-step/2
       value[i]<-value[i-1]+step*funni(t/std)/std
       #funni(t/std,g=g,a=a,b=b,d=d)/std
   }
}

index<-seq(1:N)
len<-length(index)
down<-matrix(0,len,1)
high<-matrix(0,len,1)
down[,1]<-index-1
high[,1]<-index

res<-list(
value=value,
down=down,high=high,
#down=index-1,high=index,  
support=support,N=N)

return(res)
}

                              

eval.func.dD<-function(func,N,
sig=rep(1,length(N)),support=NULL,theta=NULL,g=1,
M=NULL,p=NULL,mul=3,
t=rep(1,length(N)),marginal="normal",r=0,
mu=NULL,xi=NULL,Omega=NULL,alpha=NULL,df=NULL,a=0.5,b=0.5
)   
# func== "mixt", "epan", "cop1"
{
d<-length(N)
recnum<-prod(N)
value<-matrix(0,recnum,1)
index<-matrix(0,recnum,d)

if (is.null(support)){

   if (func=="mixt"){
     support<-matrix(0,2*d,1)
        for (i in 1:d){
           support[2*i-1]<-min(M[,i]-mul*sig[,i])
           support[2*i]<-max(M[,i]+mul*sig[,i])
        }
   }

   if (func=="epan"){
      if (is.null(sig)) sig<-c(1,1)
      support<-matrix(0,2*d,1)
      for (i in 1:d){
          support[2*i-1]<--sig[i]
          support[2*i]<-sig[i]
      }
   }
}

if ((marginal=="unif")) support<-c(0,sig[1],0,sig[2])
# && (is.null(support))) 
#support<-c(-sig[1]/2,sig[1]/2,-sig[2]/2,sig[2]/2)


lowsuppo<-matrix(0,d,1)
for (i in 1:d) lowsuppo[i]<-support[2*i-1]
step<-matrix(0,d,1)
for (i in 1:d) step[i]<-(support[2*i]-support[2*i-1])/N[i]

numpositive<-0
for (i in 1:recnum){
    inde<-digit(i-1,N)+1
    #if ((inde[1]==0) && (inde[2]==N[2])) inde<-c(0,0)
    point<-lowsuppo+step*inde-step/2

    if (!is.null(theta)){
         rotmat<-matrix(c(cos(theta),-sin(theta),sin(theta),cos(theta)),2,2)
         point<-rotmat%*%point
    }

    if (func=="prod") val<-eva.prod(point,marginal,g)
    if (func=="skewgauss") val<-eva.skewgauss(point,mu,sig,alpha)
    #if (func=="dmsn") val<-dmsn(point,xi,Omega,alpha)
    if (func=="student") val<-eva.student(point,t,marginal,sig,r,df)
    if (func=="gumbel") val<-eva.copula(point,
        type="gumbel",marginal=marginal,sig=sig,r=r,t=t,g=g)
    if (func=="frank") val<-eva.copula(point,
        type="frank",marginal=marginal,sig=sig,t=t,g=g)
    if (func=="plackett") val<-eva.plackett(point,t,marginal,sig)
    if (func=="clayton2") val<-eva.clayton(point,t,marginal,sig,df)
    if (func=="clayton") val<-eva.copula(point,
        type="clayton",marginal=marginal,sig=sig,r=r,t=t,g=g)
    if (func=="cop6") val<-eva.cop6(point,t,marginal,sig)
    if (func=="epan") val<-epan(point)
    if (func=="gauss") val<-eva.copula(point,
        type="gauss",marginal=marginal,sig=sig,r=r,t=t)
    if (func=="normal") val<-eva.gauss(point,t=t,marginal=marginal,sig=sig,r=r)
    if (func=="mixt"){
        val<-0
        mixnum<-length(p)
        for (mi in 1:mixnum){
            evapoint<-(point-M[mi,])/sig[mi,]
            val<-val+p[mi]*evanor(evapoint)/prod(sig[mi,])
        }
    }
   if (func=="hat") val<-eva.hat(point,a=a,b=b)

    if (val>0){
       numpositive<-numpositive+1
       value[numpositive]<-val
       index[numpositive,]<-inde
    }
}

value<-value[1:numpositive]
index<-index[1:numpositive,]
down<-index-1
high<-index

res<-list(
value=value,index=index,
down=down,high=high,  #step=delta,
support=support,N=N)

return(res)
}                              











eva.lognormal<-function(t)
{

ans<-(2*pi)^(-1/2)*t^(-1)*exp(-(log(t))^2/2)

return(ans)
}

evanor<-function(x){

d<-length(x) 
eta<-sum(x^2)     #vektorin x pituuden nelio
normvakio<-(sqrt(2*pi))^{-d}
tulos<-exp(-eta/2)*normvakio
return(tulos)
}
eva.plackett<-function(x,t,marginal="unif",sig=c(1,1))
# t>=0, t \neq 1
{
u<-x[1]
v<-x[2]
marg1<-1
marg2<-1

if (marginal=="normal"){
   u<-pnorm(x[1]/sig[1])
   v<-pnorm(x[2]/sig[2])
   marg1<-evanor(x[1]/sig[1])/sig[1]
   marg2<-evanor(x[2]/sig[2])/sig[2]
}

val<-t*(1+(t-1)*(u+v-2*u*v))*((1+(t-1)*(u+v))^2-4*t*(t-1)*u*v)^(-3/2)*marg1*marg2
#if (val<0) val<-0

return(val)
}

eva.prod<-function(x,marginal="student",g=1)
{
if (marginal=="student"){
    d<-1
    vakio<-gamma((g+d)/2)/((g*pi)^(d/2)*gamma(g/2))
    y<-vakio*(1+x^2/g)^(-(g+d)/2)
    val<-prod(y)
}
if (marginal=="student.old"){
    d<-1
    vakio<-gamma((g+d)/2)/((g*pi)^(d/2)*gamma(g/2))
    x1<-vakio*(1+x[1]^2/g)^(-(g+d)/2)
    x2<-vakio*(1+x[2]^2/g)^(-(g+d)/2)
    val<-x1*x2
}
if (marginal=="studentR"){
    #x1<-dt(x[1],df=g)
    #x2<-dt(x[2],df=g)
    y<-dt(x,df=g)
    val<-prod(y)  
}
if (marginal=="polyno.old"){
    vakio<-2*(1-1/(g+1))
    y<-vakio*abs(1-x)^g
    val<-prod(y)
}
if (marginal=="polyno"){ 
    vakio<-1/(2*(1-1/(g+1)))
    y<-vakio*abs(1-abs(x)^g)
    val<-prod(y)
}
if (marginal=="double"){
    vakio<-1/2
    y<-exp(-abs(x))
    val<-prod(y)
}
if (marginal=="gauss"){
    vakio<-(2*pi)^(-1/2)
    y<-exp(-x^2/2)
    val<-prod(y)
}

  
return(val)
}

eva.skewgauss<-function(x,mu,sig,alpha)
{

norvak<-prod(sig)^(-1)
point<-(x-mu)/sig
en<-evanor(point)     #dnorm(poi)

point2<-alpha%*%((x-mu)/sig)
pn<-pnorm(point2)

ans<-2*en*pn

return(ans)
}
eva.student<-function(x,t=rep(4,length(x)),
marginal="unif",sig=c(1,1),r=0,df=1)
# t>2 
#  sig is std of marginals
{
if (marginal=="unif"){
   u<-x[1]/sig[1]
   v<-x[2]/sig[2]
   marg1<-1/sig[1]
   marg2<-1/sig[2]
}
if (marginal=="normal"){
   u<-pnorm(x[1]/sig[1])
   v<-pnorm(x[2]/sig[2])
   marg1<-evanor(x[1]/sig[1])/sig[1]
   marg2<-evanor(x[2]/sig[2])/sig[2]
}
if (marginal=="student"){
   u<-pt(x[1]/sig[1],df=t[1])
   v<-pt(x[2]/sig[2],df=t[2])
   marg1<-dt(x[1]/sig[1],df=t[1])/sig[1]
   marg2<-dt(x[2]/sig[2],df=t[2])/sig[2]
}

d<-2
x1<-qt(u,df=df)
x2<-qt(v,df=df)
produ<-dt(x1,df=df)*dt(x2,df=df)

nelio<-(x1^2+x2^2-2*r*x1*x2)/(1-r^2)
vakio<-gamma((df+d)/2)/((df*pi)^(d/2)*gamma(df/2))
ga<-vakio*(1-r^2)^(-1/2)*(1+nelio/df)^(-(df+d)/2)
#ga<-(1-r^2)^(1/2)*(1+(x1^2+x2^2-2*r*x1*x2)/(t*(1-r^2)))^(-(t+d)/2)

val<-ga/produ*marg1*marg2

return(val)
}

excmas.bylevel<-function(lst,levnum)
{
#source("~/denpro/R/excmas.bylevel.R")
#excmas.bylevel(lst,20)

levexc<-matrix(0,levnum,1)

maxlev<-max(lst$level)
step<-maxlev/levnum
nodelkm<-length(lst$parent)

mlkm<-moodilkm(lst$parent)
modloc<-mlkm$modloc    #pointers to modes
lkm<-mlkm$lkm       

added<-matrix(0,nodelkm,1)  #1 if we have visited this node

i<-1
while (i<=lkm){
    node<-modloc[i]
    # calculate curexc
    par<-lst$parent[node]
    if (par==0) valpar<-0 else valpar<-lst$level[par] 
    curexc<-(lst$level[node]-valpar)*lst$volume[node]
    
    nodelevind<-min(max(round(lst$level[node]/step),1),levnum)    
    levexc[1:nodelevind]<-levexc[1:nodelevind]+curexc

    while (lst$parent[node]>0){
         node<-lst$parent[node]
         if (added[node]==0){   
           # calculate curexc
           par<-lst$parent[node]
           if (par==0) valpar<-0 else valpar<-lst$level[par] 
           curexc<-(lst$level[node]-valpar)*lst$volume[node] 
           
           nodelevind<-min(max(round(lst$level[node]/step),1),levnum)    
           levexc[1:nodelevind]<-levexc[1:nodelevind]+curexc

           added[node]<-1 
         }
    }
    i<-i+1
}

levexc<-levexc/levexc[1]

diffe<-matrix(0,length(levexc),1)
for (i in 1:(length(levexc)-1)) diffe[i]<-(levexc[i+1]-levexc[i])/step
diffe[length(diffe)]<-diffe[length(diffe)-1]

return(list(levexc=levexc,diffe=diffe))
}




excmas<-function(lst){
#
parents<-lst$parent
volumes<-lst$volume
levels<-lst$level
#
nodelkm<-length(parents)
excmasses<-matrix(1,nodelkm,1)
#
mlkm<-moodilkm(parents)
modloc<-mlkm$modloc    #pointers to modes
lkm<-mlkm$lkm       
#
added<-matrix(0,nodelkm,1)  #1 if we have visited this node
#
for (i in 1:lkm){
    node<-modloc[i]
    # calculate curexc
    par<-parents[node]
    if (par==0) valpar<-0 else valpar<-levels[par] 
    curexc<-(levels[node]-valpar)*volumes[node]
    #
    excmasses[node]<-curexc
    while (parents[node]>0){
         node<-parents[node]
         if (added[node]==0){   
           # calculate curexc
           par<-parents[node]
           if (par==0) valpar<-0 else valpar<-levels[par] 
           curexc<-curexc+(levels[node]-valpar)*volumes[node] 
           #
           excmasses[node]<-curexc 
           added[node]<-1 
         }
         else{   #add only previous cumulative 
            excmasses[node]<-excmasses[node]+curexc
         }
    }
}
return(t(excmasses))
}




exmap<-function(estiseq,mt,hind=NULL,hseq=NULL,
n=NULL,moteslist=NULL,ylist=NULL)
{
#moteslist is a list of alpha values for every node
#not just for the branch nodes, but it might be nonsense for others

pk<-estiseq$lstseq
if (is.null(hseq)) hseq<-mt$hseq
if (is.null(hind)) hind<-c(1:length(mt$hseq))
slis<-mt$hseq[hind]

d<-dim(pk[[1]]$center)[1]

if (is.null(ylist)) ylist<-c(length(slis):1)

hrun<-1
for (i in 1:length(slis)){
   while (hseq[hrun]!=slis[i]){
      hrun<-hrun+1
   }
   if (i==1) treelist<-list(pk[[hrun]])
   else  treelist=c(treelist,list(pk[[hrun]]))
}

parnum<-length(slis)
veclkm<-0

if (d==1){
  crit<-max(treelist[[1]]$center)
}
else{
  crit<-rep(0,d)
}

for (i in 1:parnum){
     scur<-slis[i]

     if (!is.null(ylist))  yhigh<-ylist[i]
     else yhigh<-scur     

     profile<-treelist[[i]]
     
     if (!is.null(moteslist))  motes<-moteslist[[i]]
     else motes<-NULL

     level<-scur
     levelplot<-yhigh

     vecplu<-prof2vecs(profile,levelplot,n,crit,motes=motes)
     vecs<-vecplu$vecs
     depths<-vecplu$depths
     motes<-vecplu$motes
     mlabel<-vecplu$mlabel
     vecnum<-length(depths)
     smoot<-matrix(level,vecnum,1)
     
     # concatenate to big's
     
     veclkmold<-veclkm
     veclkm<-veclkm+vecnum
     if (veclkmold==0){   
        bigvecs<-vecs
        bigdepths<-depths
        bigmotes<-motes
        bigmlabel<-mlabel
        bigsmoot<-smoot
     }
     else{
       temp<-matrix(0,veclkm,4)
       temp[1:veclkmold,]<-bigvecs
       temp[(veclkmold+1):veclkm,]<-vecs
       bigvecs<-temp
       
       tempdep<-matrix(0,veclkm,1)
       tempdep[1:veclkmold]<-bigdepths
       tempdep[(veclkmold+1):veclkm]<-depths
       bigdepths<-tempdep
       
       tempmoo<-matrix(0,veclkm,1)
       tempmoo[1:veclkmold]<-bigmotes
       tempmoo[(veclkmold+1):veclkm]<-motes
       bigmotes<-tempmoo
       
       templab<-matrix(0,veclkm,1)
       templab[1:veclkmold]<-bigmlabel
       templab[(veclkmold+1):veclkm]<-mlabel
       bigmlabel<-templab
       
       tempsmoo<-matrix(0,veclkm,1)
       tempsmoo[1:veclkmold]<-bigsmoot
       tempsmoo[(veclkmold+1):veclkm]<-smoot
       bigsmoot<-tempsmoo
     }
}    
#if (makeplot==T) plotvecs(bigvecs,segme=T,bigdepths) 

return(list(bigvecs=bigvecs,bigdepths=t(bigdepths),motes=t(bigmotes),mlabel=t(bigmlabel),smoot=t(bigsmoot)))
}







explo.compa<-function(dendat,seed=1)
{
n<-dim(dendat)[1]
d<-dim(dendat)[2]

cova<-cov(dendat)
mu<-mean(data.frame(dendat))

eig<-eigen(cov(dendat),symmetric=TRUE)
sigsqm<-eig$vectors%*%diag(eig$values^{1/2})  #%*%t(eig$vectors)

set.seed(seed)
symmedata<-matrix(rnorm(d*n),n,d)
dendat.simu<-t(sigsqm%*%t(symmedata))

return(dendat.simu)
}

findbranch.pare<-function(parent)
{
# finds the nodes who have more than 1 child

len<-length(parent)
frekve<-matrix(0,len,1)

for (i in 1:len){
   if (parent[i]>0) frekve[parent[i]]<-frekve[parent[i]]+1
}

tulos<-matrix(0,len,1)

for (i in 1:len){
     #if (parent[i]==0) tulos[i]<-1
     #else 
     if ((parent[i]!=0) && (frekve[parent[i]]>1)){ #result of a branching
                 tulos[parent[i]]<-1
    }
}

if (sum(tulos)==0) ans<-NULL else ans<-which(tulos==1)

return(ans)
}    
findbranch<-function(parent,colo="red1",pch=22)
{
# finds the nodes which make the tree of the branches

#pch=19: solid circle, pch=20: bullet (smaller circle), 
#pch=21: circle, pch=22: square, 
#pch=23: diamond, pch=24: triangle point-up, 
#pch=25: triangle point down. 

len<-length(parent)
frekve<-matrix(0,len,1)

for (i in 1:len){
   if (parent[i]>0) frekve[parent[i]]<-frekve[parent[i]]+1
}

tulos<-matrix(0,len,1)
colovec<-matrix("black",len,1)
pchvec<-matrix(21,len,1)

for (i in 1:len){
    if (parent[i]==0){ #root node
             tulos[i]<-1  
             colovec[i]<-colo
             pchvec[i]<-pch
 
    }  
    else if (frekve[parent[i]]>1){ #result of a branching
                 tulos[i]<-1
                 colovec[i]<-colo
                 pchvec[i]<-pch  
    }
}

return(list(indicator=tulos,colovec=colovec,pchvec=pchvec))
}    
findend<-function(inde,left,right,low,upp,N){
#
lenn<-length(inde)
current<-1
dep<-1
if ((left[current]==0) && (right[current]==0)){
   exists<-FALSE
   }
else{
   exists<-TRUE
}
while ((exists) && ((left[current]>0) || (right[current]>0))){
     mid<-(low[current]+upp[current])/2 
     direc<-depth2com(dep,N)$direc 
     if (inde[direc]<=mid){
           if (left[current]>0){ 
                current<-left[current]
                dep<-dep+1
           }
           else{ 
                exists<-FALSE
           }
     }
     else{   
           if (right[current]>0){
                  current<-right[current]
                  dep<-dep+1
           }
           else{
               exists<-FALSE
           }
     }
}
return(list(exists=exists,location=current,dep=dep))
}
findleafs<-function(left,right)
{
# Finds location of leafs in binary tree, living in vector
# left, right are itemnum-vectors

# returns itemnum-vector, 1 in the location of nodes 0 non-terminal
# NA in positions not belonging to tree

# vector where binary tree is living may be larger than cardinality
# of nodes of the tree

itemnum<-length(left)
leafloc<-matrix(NA,itemnum,1)
pino<-matrix(0,itemnum,1)
pino[1]<-1     #pino[1]<-root
pinin<-1
while (pinin>0){
    cur<-pino[pinin]      #take from stack
    pinin<-pinin-1
    if (left[cur]==0){    #if we are in leaf
       leafloc[cur]<-1
    }
    else{
       while (left[cur]>0){  #go to leaf and put right nodes to stack
           leafloc[cur]<-0
           pinin<-pinin+1
           pino[pinin]<-right[cur]
           cur<-left[cur]
       }
       leafloc[cur]<-1  #now we know we are in leaf
    }
}
return(leafloc)
} 







findneighbor<-function(lst,node)
{
mu<-multitree(lst$parent)

no<-lst$parent[node]
while ((no!=0) && (mu$sibling[mu$child[no]]==0)){
     no<-lst$parent[no]
}


return(no)
}

graph.matrix.level<-function(dendat,tt=NULL,permu=seq(1:dim(dendat)[1]),
col=seq(1:2000),config="new",shift=0.1,segme=TRUE,poin=FALSE,epsi=0,
ystart=0.5,pch=21,cex=1, yaxt="s",cex.axis=1)
{
n<-dim(dendat)[1]
d<-dim(dendat)[2]

origins<-matrix(0,d,1)
starts<-matrix(0,d,1)
range<-matrix(0,d,1)
minis<-matrix(0,d,1)
means<-matrix(0,d,1)
for (i in 1:d){
    minis[i]<-min(dendat[,i]) 
    means[i]<-mean(dendat[,i])
}

for (i in 1:d) range[i]<-max(dendat[,i])-min(dendat[,i]) 
starts[1]<-0 #min(dendat[,1])
i<-2
while (i<=d){ 
      starts[i]<-starts[i-1]+range[i-1]+epsi
      i<-i+1
}
if (config=="new")
  for (i in 1:d) origins[i]<-starts[i]+mean(dendat[,i])-min(dendat[,i])
else
  for (i in 1:d) origins[i]<-starts[i]+range[i]/2-min(dendat[,i])

  #starts[i]+range[i]/2

plot(x="",y="",xlim=c(starts[1],starts[d]+range[d]),ylim=c(ystart,n+0.5),
xlab="",ylab="",xaxt="n",yaxt=yaxt,cex.axis=cex.axis)

if (is.null(tt)){

   for (j in 1:d){
      for (i in 1:n){
           indo<-permu[i]
           x0<-dendat[indo,j]+starts[j]-min(dendat[,j]) 
                    #dendat[indo,j]+origins[j]
           y0<-i
           x1<-origins[j]  
           y1<-i
           if (segme)
           segments(x0, y0, x1, y1, col=col[indo])
           if (poin)          
           points(x0, y0, col=col[indo], pch=pch, cex=cex)


       }
       if (j>1){
            beg<-starts[j]-epsi/2 
            segments(beg,0.5,beg,n+0.5,lty=1,lwd=2)
       }
       segments(origins[j],1,origins[j],n,lty=2)
       text(origins[j],ystart,as.character(round(means[j],digits=2)),cex=cex)
       text(starts[j]+shift,ystart,as.character(round(minis[j],digits=2)),
       cex=cex)
   }

}

else{
   paletti<-seq(1:2000)
   coli<-colobary(tt$parent,paletti)  #,segtype="num")

   cente<-c(mean(dendat[,1]),mean(dendat[,2]))
   dendat3<-matrix(0,n,d)
   newcolo<-matrix(0,n,1)
   maxseg<-max(coli)
   curbeg<-1
   i<-maxseg
   while (i >= 1){
       inditree<-which(coli==i)
       indidendat<-tt$infopointer[inditree]
       curend<-curbeg+length(indidendat)-1
       curseg<-dendat[indidendat,]
       leveli<-sqrt(sum(curseg-cente)^2)    #pituus(curseg-cente))
       or<-order(leveli)
       if (length(or)>1) orseg<-curseg[or,] else orseg<-curseg
       dendat3[curbeg:curend,]<-orseg
       newcolo[curbeg:curend]<-i
       curbeg<-curend+1  #curbeg+length(indit)+1
       i<-i-1
   }

   for (j in 1:d){
       for (i in 1:n){
           x0<-dendat3[i,j]+starts[j]-min(dendat3[,j]) 
               #dendat3[i,j]+origins[j]
           y0<-i
           x1<-origins[j]
           y1<-i
           #segments(x0, y0, x1, y1,col=newcolo[i])
           if (segme)
           segments(x0, y0, x1, y1, col=newcolo[i])
           if (poin)          
           points(x0, y0, col=newcolo[i],pch=pch,cex=cex)

       }
       if (j>1){
            beg<-starts[j]-epsi/2 
            segments(beg,0.5,beg,n+0.5,lty=1,lwd=2)
       }
       segments(origins[j],1,origins[j],n,lty=2)
       text(origins[j],ystart,as.character(round(means[j],digits=2)),cex=cex)
       text(starts[j]+shift,ystart,as.character(round(minis[j],digits=2)),
       cex=cex)
   }

}  # else

}






graph.matrix<-function(dendat,type="level",
tt=NULL,permu=seq(1:dim(dendat)[1]),col=seq(1:2000),
config="new",shift=0.1,segme=TRUE,poin=FALSE,epsi=0,ystart=0.5, 
pch=21, cex=1, cex.axis=1, yaxt="s",
# profile:
ylen=100,profcol=rep("black",n))
{
if (type=="level") 
 graph.matrix.level(dendat, tt=tt, permu=permu, col=col,
 config=config, shift=shift, segme=segme, poin=poin, epsi=epsi, ystart=ystart,
 pch=pch, cex=cex, yaxt=yaxt, cex.axis=cex.axis)

else{  # type="profile"
 n<-dim(dendat)[1]
 d<-dim(dendat)[2]
 x<-seq(1:n)
 y<-seq(1:ylen)
 z<-matrix(0,length(x),length(y))
 varit<-matrix("",length(x),length(y))
 ala<-matrix(0,d,1)
 for (i in 1:d) ala[i]<-min(dendat[,i])
 yla<-matrix(0,d,1)
 for (i in 1:d) yla[i]<-max(dendat[,i])
 range<-yla-ala
 alaind<-matrix(0,d,1)
 alaind[1]<-1
 for (i in 2:d) 
     alaind[i]<-min(alaind[i-1]+round(ylen*range[i]/sum(range))+1,ylen)
 ylaind<-matrix(0,d,1)
 ylaind[d]<-ylen
 for (i in 1:(d-1)) ylaind[i]<-alaind[i+1]+1
 plot(x="",y="",xlim=c(0,n),ylim=c(0,ylen),xlab="",ylab="",yaxt="n",xaxt="n")
 for (i in 1:n){
     for (j in 1:d){
         suht<-(dendat[i,j]-ala[j])/range[j]
         korkeus<-round(suht*(ylaind[j]-alaind[j]))
         alku<-alaind[j]
         loppu<-min(max(alku+korkeus,1),ylen)
         if (alku>=loppu) loppu<-loppu+1
         polygon(x=c(i-1,i-1,i,i),y=c(alku,loppu,loppu,alku),col=profcol[i],
                 lty="blank")
         #z[i,alku:loppu]<-1
     }
 }
 #image(x,y,z,col=c("white","black"),xlab="",ylab="",xaxt="n",yaxt="n")
}

}




hgrid<-function(h1,h2,lkm,base=10)
{
step<-(h2-h1)/(lkm-1)

if (is.null(base)){
   hseq<-seq(h2,h1,-step)
}
else{
   a<-(h2-h1)/(base^(h2)-base^(h1))
   b<-h1-a*base^(h1)
   un<-seq(h2,h1,-step)
   hseq<-a*base^(un)+b
}

return(hseq)
}

histo1d<-function(dendat,binlkm,ala=NULL,yla=NULL,
pic=TRUE,brush=NULL,brushcol=c("blue"),col=NULL,border=NULL,
xlab="",ylab="",cex.lab=1,cex.axis=1,data=FALSE,
weights=rep(1,length(dendat)),normalization=TRUE,
height=NULL,subweights=NULL,graphplot=FALSE)
{
if (is.null(ala)) ala<-min(dendat)
if (is.null(yla)) yla<-max(dendat)
step<-(yla-ala)/binlkm
frekv<-matrix(0,binlkm,1)
value<-matrix(0,binlkm,1)
if (!is.null(brush)){
   cnum<-max(brush)
   shade <-matrix(0,binlkm,cnum)
}
if (!is.null(subweights)) taint<-matrix(0,binlkm,1)
n<-length(dendat)
for (i in 1:n){
   hava<-dendat[i]
   weight<-weights[i]
   ind<-min(binlkm,floor((hava-ala)/step)+1)
   frekv[ind]<-frekv[ind]+weight
   if ((!is.null(brush)) && (brush[i]>0)) 
              shade[ind,brush[i]]<-shade[ind,brush[i]]+1
   if (!is.null(subweights)) taint[ind]<-taint[ind]+n*subweights[i]
}
if (normalization) value<-frekv/(n*step) else value<-frekv
if (!is.null(brush)) shade<-shade/(n*step)
if ((normalization) && (!is.null(subweights))) taint<-taint/(n*step)

if (pic){
   if (is.null(height)) height<-max(value)
   plot(x="",y="",xlab=xlab,ylab=ylab,xlim=c(ala,yla),ylim=c(0,height),
   cex.lab=cex.lab,cex.axis=cex.axis)
   for (i in 1:binlkm){
          xala<-ala+(i-1)*step
          xyla<-xala+step
          y<-value[i]

          if (graphplot){
               if (i==1) yeka<-0 else yeka<-value[i-1]
               if (i==binlkm) ytok<-0 else ytok<-value[i]
               segments(xala,yeka,xala,ytok)
               segments(xala,ytok,xyla,ytok)
          } 
          else
          polygon(c(xala,xala,xyla,xyla),c(0,y,y,0),col=col,border=border)

          if (!is.null(brush)){
              y0<-0
              for (kk in 1:cnum){
                  y<-y0+shade[i,kk]
                  polygon(c(xala,xala,xyla,xyla),c(y0,y,y,y0),col=brushcol[kk])
                  y0<-y
              }
          }
          if (!is.null(subweights)){
              if (graphplot){
                 if (i==1) yeka<-0 else yeka<-taint[i-1]
                 if (i==binlkm) ytok<-0 else ytok<-taint[i]
                 segments(xala,yeka,xala,ytok,col=brushcol)
                 segments(xala,ytok,xyla,ytok,col=brushcol)
              } 
              else{
                 y<-taint[i]
                 polygon(c(xala,xala,xyla,xyla),c(0,y,y,0),col=brushcol)
              } 
          }
   }
}
if (data){
     return(list(frekv=frekv,ala=ala,step=step,value=value))
}
}



histo<-function(dendat,binlkm,epsi=0)
{
# Constructs a histogram estimate: result is given by giving level
# sets of the estimate

supp<-support(dendat,epsi)
regdat<-den2reg(dendat,binlkm,supp)
palvak<-makehis(regdat)
values<-palvak$values
recs<-palvak$recs

integ<-0
recnum<-length(values)
for (i in 1:recnum){
   integ<-integ+values[i]*massone(recs[i,])
}

values<-values/integ

return(list(values=values,recs=recs))
}




intersec<-function(taso,endind,cur,uni){
#Makes from a set of rectangles "cur" a larger rectangle.
#For a given rectangle in cur, we make intersection with
#rectangles in uni, starting with rectangle after the point
#indicated in "endind". 
#Result is a set of k over "taso" rectangles, where k is the number
#of rectangles in "uni". 
#uni has the basic sets, we have in cur all the (taso-1)-fold
#intersections of uni, we want to form taso-fold intersections,
#in endind we have index of the last rectangle in (taso-1)-fold
#intersection: we have to form intersections with all the rest
#rectangles in uni. Thus result has the size: how many subsets of
#size taso, we can take from a set of size k. 
#
#taso is integer >=1
#endind is l-vector
#cur is l*(2*d)-matrix
#uni is k*(2*d)-matrix, huom oletetaan etta k>1!!!!!
#
#Return NA if there is no intersectio, otherwise
#list(set=tulos,endind=newendind)
#
k<-length(uni[,1])   #rows of uni
d2<-length(uni[1,])  #col of uni is the 2*d
tulrow<-choose(k,taso)
#tulrow<-gamma(k+1)/(gamma(k-taso+1)*gamma(taso+1))#k yli taso,gamma(k)=(k-1)!
newendind<-matrix(0,tulrow,1)
tulos<-matrix(0,tulrow,d2)
ind<-0        #indeksi to tulos and newendind
if (dim(t(cur))[1]==1) a<-1 else a<-length(cur[,1])  #rows of cur
for (i in 1:a){
  if (endind[i]<k){
    for (j in (endind[i]+1):k){
      if (a==1) apu<-leikkaa(cur,uni[j,])
        else apu<-leikkaa(cur[i,],uni[j,])
         #for (l in 1:d){
         #  tulos[ind,2*l-1]<-max(cur[i,2*l-1],uni[j,2*l-1])
         #  tulos[ind,2*l]<-min(cur[i,2*l],uni[j,2*l])
         #}      
      if (!is.na(apu)){  #if there is intersection, save the result
         ind<-ind+1
         tulos[ind,]<-apu
         newendind[ind]<-j
      }
    }
  }
}
if (ind==0) palauta<-NA
else{
  tulos<-tulos[1:ind,]
  newendind<-newendind[1:ind]
  palauta<-list(set=tulos,endind=newendind)
}
return(palauta) 
}







joincongen<-function(leftbeg,rightbeg,separy,
begsSepaNext,begsSepaBegs,begsLeftBoun,begsRighBoun,
atomsSepaNext,atomsSepaAtom,atomsLBounNext,atomsRBounNext,
direction,low,upp)
{
#upp and low are terminalnum*d matrices
#vrt index: we have links from the tree to this data structure
#we know that coordinate "direction" touches
#
#
# 1. We find the startpoints for the sets
#
# we will make three vectors of startpoints:
# a. startpoints for the whole sets (concatenate left and right child)
#    (startpointsS)
# b. startpoints for the right boundary of the left child and 
#    left boundary of the right child
#    (startpointsB)
# c.1. startpoints for the left boundary of the left child a
#    (startpointsNewBleft)
# c.2. startpoints for the right boundary of the right child
#    (startpointsNewBright)
#
#
# startpoints are pointers to 
# a. atomsSepaAtoms/atomsSepaNext
# b. atomsSepaAtoms/atomsRBounNext, atomsSepaAtoms/atomsLBounNext
# c.1. atomsSepaAtoms/atomsLBounNext
# c.2.  atomsSepaAtoms/atomsRBounNext
#
# startpoints are found from 
# a. begsSepaBegs
# b. begsLeftBoun, begsRighBoun
# c.1 begsLeftBoun, 
# c.2 begsRighBoun
#
# b. is used to check which touch
# a., c.1. and c.2. are joined together
# Note that some sets of the boundary are empty 
# (we store 0 to the respective location in begsLeftBoun, begsRighBoun )

suppi<-length(begsSepaNext)
startpointsS<-matrix(0,suppi,1)
startpointsB<-matrix(0,suppi,1)
startpointsNewBleft<-matrix(0,suppi,1)
startpointsNewBright<-matrix(0,suppi,1)
#new boundary: left bound. of left child, right b. of right child

induksi<-1
anfang<-separy[leftbeg]
startpointsS[induksi]<-anfang
startpointsB[induksi]<-begsRighBoun[anfang]
startpointsNewBleft[induksi]<-begsLeftBoun[anfang]
while (begsSepaNext[anfang]>0){
  anfang<-begsSepaNext[anfang]
  induksi<-induksi+1
  startpointsS[induksi]<-begsSepaBegs[anfang]
  startpointsB[induksi]<-begsRighBoun[anfang]
  startpointsNewBleft[induksi]<-begsLeftBoun[anfang]  
}
mleft<-induksi
induksi<-induksi+1
anfang<-separy[rightbeg]
startpointsS[induksi]<-anfang
startpointsB[induksi]<-begsLeftBoun[anfang]
startpointsNewBright[induksi]<-begsRighBoun[anfang]
while (begsSepaNext[anfang]>0){
  anfang<-begsSepaNext[anfang]
  induksi<-induksi+1
  startpointsS[induksi]<-begsSepaBegs[anfang]
  startpointsB[induksi]<-begsLeftBoun[anfang]
  startpointsNewBright[induksi]<-begsRighBoun[anfang]  

}
startpointsS<-startpointsS[1:induksi]
startpointsB<-startpointsB[1:induksi]
startpointsNewBleft<-startpointsNewBleft[1:induksi]
startpointsNewBright<-startpointsNewBright[1:induksi]
m<-induksi
mright<-m-mleft  


# 2. We make "links" matrix and apply declev

# We utilize previous programs

linkit<-matrix(0,m,m)
do<-1
while (do <= mleft){
   beg1<-startpointsB[do]    #could be 0
   re<-mleft+1
   while (re <= m){
       beg2<-startpointsB[re]    #could be 0
       conne<-FALSE
       begbeg1<-beg1
       while (begbeg1>0){
            begbeg2<-beg2
            while (begbeg2>0){
                atom1<-atomsSepaAtom[begbeg1]
                indelow1<-low[atom1,]
                indeupp1<-upp[atom1,]
                atom2<-atomsSepaAtom[begbeg2]
                indelow2<-low[atom2,]
                indeupp2<-upp[atom2,]
                if (dotouchgen(indelow1,indeupp1,indelow2,indeupp2,direction)){
                   conne<-TRUE
                }
                begbeg2<-atomsLBounNext[begbeg2]
            }
            begbeg1<-atomsRBounNext[begbeg1]
       }                
       if (conne){
           linkit[do,re]<-1
       }
       re<-re+1
   }
   do<-do+1
}
for (do in (mleft+1):m){
   beg1<-startpointsB[do]
   for (re in 1:mleft){
       beg2<-startpointsB[re]
       conne<-FALSE
       begbeg1<-beg1
       while (begbeg1>0){
            begbeg2<-beg2
            while (begbeg2>0){
                atom1<-atomsSepaAtom[begbeg1]
                indelow1<-low[atom1,]
                indeupp1<-upp[atom1,]
                atom2<-atomsSepaAtom[begbeg2]
                indelow2<-low[atom2,]
                indeupp2<-upp[atom2,]
                if (dotouchgen(indelow1,indeupp1,indelow2,indeupp2,direction)){
                   conne<-TRUE
                }
                begbeg2<-atomsRBounNext[begbeg2]
            }
            begbeg1<-atomsLBounNext[begbeg1]
       }                
       if (conne){
           linkit[do,re]<-1
      }
   }
} 
# huom ylla on nopeutettu, koska tiedetaan, etta atomit
# 1,...,mleft eivat koske toisiaan ja samoin atomit mleft+1,...,m
#
# next we apply "declev" 
rindeksitB<-seq(1,m)
res<-declevnew(rindeksitB,linkit,m)   #res is sepnum*m-matrix of 0/1
sepnum<-dim(res)[1]
# 
# res is sepnum*m-matrix, 1 in some row indicates that set (atom)
# belongs to this component, 0 in other positions
#
# output could be also a vector which contains pointers
# to a list of elements (in one list we find those sets which
# belong to the same component
#
#compopointer<-matrix(0,sepnum,1) 
#compoSet<-matrix(0,m,1)
#compoNext<-matrix(0,m,1)
#
#
#3. We join the sets 
#
# We join the sets whose startpoints are in 
# startpointsS and startpointsNewBleft, startpointsNewBright
# We have pointers separy[leftbeg] and separy[rightbeg]
# which contain pointers to lists which we can utilize
# to make a new list (these two lists contain together at most as many 
# elements as we need)
# 
# cut first list or (join these two lists and cut second)
#
TotalBeg<-separy[leftbeg]
#
tavoite<-1
hiihtaja<-TotalBeg
while ((begsSepaNext[hiihtaja]>0) && (tavoite<sepnum)){
   hiihtaja<-begsSepaNext[hiihtaja]
   tavoite<-tavoite+1
}  
if (tavoite<sepnum){  #now hiihtaja points to the end of the first list
   #join the lists
   begsSepaNext[hiihtaja]<-separy[rightbeg]
   #we continue
   hiihtaja<-separy[rightbeg]
   tavoite<-tavoite+1
   while ((begsSepaNext[hiihtaja]>0) && (tavoite<sepnum)){
      hiihtaja<-begsSepaNext[hiihtaja]
      tavoite<-tavoite+1
   }    
   begsSepaNext[hiihtaja]<-0
}
else{  #we have reached goal, cut without joining
   begsSepaNext[hiihtaja]<-0
}
#
#
nykyinen<-TotalBeg
i<-1
while (i<= sepnum){
  len<-sum(res[i,])            # number of sets to be joined
  #
  # we find vectors which contain pointer to the beginnings
  # of lists of atoms
  #
  osoittajaS<-matrix(0,len,1)  #make vector of pointers to the begs of sets
  osoittajaNewBleft<-matrix(0,len,1)
  osoittajaNewBright<-matrix(0,len,1)
  laskuri<-1
  for (j in 1:m){
     if (res[i,j]==1){
          osoittajaS[laskuri]<-startpointsS[j]  
          osoittajaNewBleft[laskuri]<-startpointsNewBleft[j]    #could be 0
          osoittajaNewBright[laskuri]<-startpointsNewBright[j]  #could be 0
          laskuri<-laskuri+1
     }    
  }
  #
  # handle separy 
  #
  begsSepaBegs[nykyinen]<-osoittajaS[1]    #always non-zero
  #
  k<-1
  while (k<=(len-1)){    
      curre<-osoittajaS[k]
      while (atomsSepaNext[curre]>0){    #find the end
          curre<-atomsSepaNext[curre]
      }
      atomsSepaNext[curre]<-osoittajaS[k+1]
      k<-k+1
  }
  #
  # handle left boundary
  #
  # set kL=0 if all 0 , otherwise kL first nonzero
  #
  k<-1
  while ((k<=len) && (osoittajaNewBleft[k]==0)){
      k<-k+1
  }
  if (k>len){   # all zero
     kL<-0
     begsLeftBoun[nykyinen]<-0
  }
  else{         # kL is first non zero
     kL<-k
     begsLeftBoun[nykyinen]<-osoittajaNewBleft[kL]  
  #
  # update the list of left boundaries
  # concatenate the lists of atoms
  #
  k<-kL
  while (k<=(len-1)){    
      curre<-osoittajaNewBleft[k]         # curre is not zero
      while (atomsLBounNext[curre]>0){    #find the end
            curre<-atomsLBounNext[curre]
      }
      # find the next non zero
      k<-k+1
      while ((k<=len) && (osoittajaNewBleft[k]==0)){
           k<-k+1
      }
      if (k>len){
          atomsLBounNext[curre]<-0
      }
      else{  # found nonzero
          atomsLBounNext[curre]<-osoittajaNewBleft[k]
      }
  }
  }
  #
  # handle right boundary
  #
  # set kR=0 if all 0 , otherwise kR first nonzero
  #
  k<-1
  while ((k<=len) && (osoittajaNewBright[k]==0)){
      k<-k+1
  }
  if (k>len){
     kR<-0
     begsRighBoun[nykyinen]<-0
  }
  else{
     kR<-k
     begsRighBoun[nykyinen]<-osoittajaNewBright[kR]  
  #
  # update the list of right boundaries
  # concatenate the lists of atoms
  #
  k<-kR
  while (k<=(len-1)){    
      curre<-osoittajaNewBright[k]         # curre is not zero
      while (atomsRBounNext[curre]>0){    #find the end
            curre<-atomsRBounNext[curre]
      }
      # find the next non zero
      k<-k+1
      while ((k<=len) && (osoittajaNewBright[k]==0)){
           k<-k+1
      }
      if (k>len){
          atomsRBounNext[curre]<-0
      }
      else{  # found nonzero
          atomsRBounNext[curre]<-osoittajaNewBright[k]
      }
  }
  }
  #
  # we move to the next sepaset
  nykyinen<-begsSepaNext[nykyinen]
  i<-i+1
}
#
return(list(totbegSepary=TotalBeg,separy=separy,
begsSepaNext=begsSepaNext,begsSepaBegs=begsSepaBegs,
begsLeftBoun=begsLeftBoun,begsRighBoun=begsRighBoun,
atomsSepaNext=atomsSepaNext,atomsSepaAtom=atomsSepaAtom,
atomsLBounNext=atomsLBounNext,atomsRBounNext=atomsRBounNext))
}























joinconne<-function(leftbeg,rightbeg,separy,
begsSepaNext,begsSepaBegs,begsLeftBoun,begsRighBoun,
atomsSepaNext,atomsSepaAtom,atomsLBounNext,atomsRBounNext,
direction,index){
#
#
# 1. We find the startpoints for the sets
#
# we will make three vectors of startpoints:
# a. startpoints for the whole sets (concatenate left and right child)
#    (startpointsS)
# b. startpoints for the right boundary of the left child and 
#    left boundary of the right child
#    (startpointsB)
# c.1. startpoints for the left boundary of the left child a
#    (startpointsNewBleft)
# c.2. startpoints for the right boundary of the right child
#    (startpointsNewBright)
#
#
# startpoints are pointers to 
# a. atomsSepaAtoms/atomsSepaNext
# b. atomsSepaAtoms/atomsRBounNext, atomsSepaAtoms/atomsLBounNext
# c.1. atomsSepaAtoms/atomsLBounNext
# c.2.  atomsSepaAtoms/atomsRBounNext
#
# startpoints are found from 
# a. begsSepaBegs
# b. begsLeftBoun, begsRighBoun
# c.1 begsLeftBoun, 
# c.2 begsRighBoun
#
# b. is used to check which touch
# a., c.1. and c.2. are joined together
# Note that some sets of the boundary are empty 
# (we store 0 to the respective location in begsLeftBoun, begsRighBoun )
#
suppi<-length(begsSepaNext)
startpointsS<-matrix(0,suppi,1)
startpointsB<-matrix(0,suppi,1)
startpointsNewBleft<-matrix(0,suppi,1)
startpointsNewBright<-matrix(0,suppi,1)
#new boundary: left bound. of left child, right b. of right child
#
induksi<-1
anfang<-separy[leftbeg]
startpointsS[induksi]<-anfang
startpointsB[induksi]<-begsRighBoun[anfang]
startpointsNewBleft[induksi]<-begsLeftBoun[anfang]
while (begsSepaNext[anfang]>0){
  anfang<-begsSepaNext[anfang]
  induksi<-induksi+1
  startpointsS[induksi]<-begsSepaBegs[anfang]
  startpointsB[induksi]<-begsRighBoun[anfang]
  startpointsNewBleft[induksi]<-begsLeftBoun[anfang]  
}
mleft<-induksi
induksi<-induksi+1
anfang<-separy[rightbeg]
startpointsS[induksi]<-anfang
startpointsB[induksi]<-begsLeftBoun[anfang]
startpointsNewBright[induksi]<-begsRighBoun[anfang]
while (begsSepaNext[anfang]>0){
  anfang<-begsSepaNext[anfang]
  induksi<-induksi+1
  startpointsS[induksi]<-begsSepaBegs[anfang]
  startpointsB[induksi]<-begsLeftBoun[anfang]
  startpointsNewBright[induksi]<-begsRighBoun[anfang]  

}
startpointsS<-startpointsS[1:induksi]
startpointsB<-startpointsB[1:induksi]
startpointsNewBleft<-startpointsNewBleft[1:induksi]
startpointsNewBright<-startpointsNewBright[1:induksi]
m<-induksi
mright<-m-mleft  
#
#
# 2. We make "links" matrix and apply declev
#
# We utilize previous programs
#
linkit<-matrix(0,m,m)
do<-1
while (do <= mleft){
   beg1<-startpointsB[do]    #could be 0
   re<-mleft+1
   while (re <= m){
       beg2<-startpointsB[re]    #could be 0
       conne<-FALSE
       begbeg1<-beg1
       while (begbeg1>0){
            begbeg2<-beg2
            while (begbeg2>0){
                atom1<-atomsSepaAtom[begbeg1]
                inde1<-index[atom1,]
                atom2<-atomsSepaAtom[begbeg2]
                inde2<-index[atom2,]
                if (dotouch(inde1,inde2,direction)){
                   conne<-TRUE
                }
                begbeg2<-atomsLBounNext[begbeg2]
            }
            begbeg1<-atomsRBounNext[begbeg1]
       }                
       if (conne){
           linkit[do,re]<-1
       }
       re<-re+1
   }
   do<-do+1
}
for (do in (mleft+1):m){
   beg1<-startpointsB[do]
   for (re in 1:mleft){
       beg2<-startpointsB[re]
       conne<-FALSE
       begbeg1<-beg1
       while (begbeg1>0){
            begbeg2<-beg2
            while (begbeg2>0){
                atom1<-atomsSepaAtom[begbeg1]
                inde1<-index[atom1,]
                atom2<-atomsSepaAtom[begbeg2]
                inde2<-index[atom2,]
                if (dotouch(inde1,inde2,direction)){
                   conne<-TRUE
                }
                begbeg2<-atomsRBounNext[begbeg2]
            }
            begbeg1<-atomsLBounNext[begbeg1]
       }                
       if (conne){
           linkit[do,re]<-1
      }
   }
} 
# huom ylla on nopeutettu, koska tiedetaan, etta atomit
# 1,...,mleft eivat koske toisiaan ja samoin atomit mleft+1,...,m
#
# next we apply "declev" 
rindeksitB<-seq(1,m)
res<-declevnew(rindeksitB,linkit,m)   #res is sepnum*m-matrix of 0/1
sepnum<-dim(res)[1]
# 
# res is sepnum*m-matrix, 1 in some row indicates that set (atom)
# belongs to this component, 0 in other positions
#
# output could be also a vector which contains pointers
# to a list of elements (in one list we find those sets which
# belong to the same component
#
#compopointer<-matrix(0,sepnum,1) 
#compoSet<-matrix(0,m,1)
#compoNext<-matrix(0,m,1)
#
#
#3. We join the sets 
#
# We join the sets whose startpoints are in 
# startpointsS and startpointsNewBleft, startpointsNewBright
# We have pointers separy[leftbeg] and separy[rightbeg]
# which contain pointers to lists which we can utilize
# to make a new list (these two lists contain together at most as many 
# elements as we need)
# 
# cut first list or (join these two lists and cut second)
#
TotalBeg<-separy[leftbeg]
#
tavoite<-1
hiihtaja<-TotalBeg
while ((begsSepaNext[hiihtaja]>0) && (tavoite<sepnum)){
   hiihtaja<-begsSepaNext[hiihtaja]
   tavoite<-tavoite+1
}  
if (tavoite<sepnum){  #now hiihtaja points to the end of the first list
   #join the lists
   begsSepaNext[hiihtaja]<-separy[rightbeg]
   #we continue
   hiihtaja<-separy[rightbeg]
   tavoite<-tavoite+1
   while ((begsSepaNext[hiihtaja]>0) && (tavoite<sepnum)){
      hiihtaja<-begsSepaNext[hiihtaja]
      tavoite<-tavoite+1
   }    
   begsSepaNext[hiihtaja]<-0
}
else{  #we have reached goal, cut without joining
   begsSepaNext[hiihtaja]<-0
}
#
#
nykyinen<-TotalBeg
i<-1
while (i<= sepnum){
  len<-sum(res[i,])            # number of sets to be joined
  #
  # we find vectors which contain pointer to the beginnings
  # of lists of atoms
  #
  osoittajaS<-matrix(0,len,1)  #make vector of pointers to the begs of sets
  osoittajaNewBleft<-matrix(0,len,1)
  osoittajaNewBright<-matrix(0,len,1)
  laskuri<-1
  for (j in 1:m){
     if (res[i,j]==1){
          osoittajaS[laskuri]<-startpointsS[j]  
          osoittajaNewBleft[laskuri]<-startpointsNewBleft[j]    #could be 0
          osoittajaNewBright[laskuri]<-startpointsNewBright[j]  #could be 0
          laskuri<-laskuri+1
     }    
  }
  #
  # handle separy 
  #
  begsSepaBegs[nykyinen]<-osoittajaS[1]    #always non-zero
  #
  k<-1
  while (k<=(len-1)){    
      curre<-osoittajaS[k]
      while (atomsSepaNext[curre]>0){    #find the end
          curre<-atomsSepaNext[curre]
      }
      atomsSepaNext[curre]<-osoittajaS[k+1]
      k<-k+1
  }
  #
  # handle left boundary
  #
  # set kL=0 if all 0 , otherwise kL first nonzero
  #
  k<-1
  while ((k<=len) && (osoittajaNewBleft[k]==0)){
      k<-k+1
  }
  if (k>len){   # all zero
     kL<-0
     begsLeftBoun[nykyinen]<-0
  }
  else{         # kL is first non zero
     kL<-k
     begsLeftBoun[nykyinen]<-osoittajaNewBleft[kL]  
  #
  # update the list of left boundaries
  # concatenate the lists of atoms
  #
  k<-kL
  while (k<=(len-1)){    
      curre<-osoittajaNewBleft[k]         # curre is not zero
      while (atomsLBounNext[curre]>0){    #find the end
            curre<-atomsLBounNext[curre]
      }
      # find the next non zero
      k<-k+1
      while ((k<=len) && (osoittajaNewBleft[k]==0)){
           k<-k+1
      }
      if (k>len){
          atomsLBounNext[curre]<-0
      }
      else{  # found nonzero
          atomsLBounNext[curre]<-osoittajaNewBleft[k]
      }
  }
  }
  #
  # handle right boundary
  #
  # set kR=0 if all 0 , otherwise kR first nonzero
  #
  k<-1
  while ((k<=len) && (osoittajaNewBright[k]==0)){
      k<-k+1
  }
  if (k>len){
     kR<-0
     begsRighBoun[nykyinen]<-0
  }
  else{
     kR<-k
     begsRighBoun[nykyinen]<-osoittajaNewBright[kR]  
  #
  # update the list of right boundaries
  # concatenate the lists of atoms
  #
  k<-kR
  while (k<=(len-1)){    
      curre<-osoittajaNewBright[k]         # curre is not zero
      while (atomsRBounNext[curre]>0){    #find the end
            curre<-atomsRBounNext[curre]
      }
      # find the next non zero
      k<-k+1
      while ((k<=len) && (osoittajaNewBright[k]==0)){
           k<-k+1
      }
      if (k>len){
          atomsRBounNext[curre]<-0
      }
      else{  # found nonzero
          atomsRBounNext[curre]<-osoittajaNewBright[k]
      }
  }
  }
  #
  # we move to the next sepaset
  nykyinen<-begsSepaNext[nykyinen]
  i<-i+1
}
#
return(list(totbegSepary=TotalBeg,separy=separy,
begsSepaNext=begsSepaNext,begsSepaBegs=begsSepaBegs,
begsLeftBoun=begsLeftBoun,begsRighBoun=begsRighBoun,
atomsSepaNext=atomsSepaNext,atomsSepaAtom=atomsSepaAtom,
atomsLBounNext=atomsLBounNext,atomsRBounNext=atomsRBounNext))
}























joingene<-function(node,leftbeg,rightbeg,separy,
begsSepaNext,begsSepaBegs,begsLeftBoun,begsRighBoun,
atomsSepaNext,atomsSepaAtom,atomsLBounNext,atomsRBounNext,
direction,index){
#
            if ((leftbeg==0) || (separy[leftbeg]==0)){
#if left child does not exist    
#note that since we consider subsets of the
#terminal nodes of the original tree, it may happen
#that leftbeg>0 but left child does not exist
                separy[node]<-separy[rightbeg]
                #we need that all lists contain as many members
                #left boundary is empty, but we will make it a list
                #of empty lists
                note<-separy[node]
                while (note>0){
                      begsLeftBoun[note]<-0
                      note<-begsSepaNext[note]
                }
                # right boundary stays same as for rightbeg
            }
            else{   # eka else
                if ((rightbeg==0) || (separy[rightbeg]==0)){  
                              #right child does not exist
                   separy[node]<-separy[leftbeg]
                   # left boundary stays same as for leftbeg
                   # right boundary is empty
                   note<-separy[node]
                   while (note>0){
                       begsRighBoun[note]<-0
                       note<-begsSepaNext[note]
                   }
                } 
                else{   #toka else: both children exist
                    #check whether left boundary of right child is empty
                    Lempty<-TRUE
                    note<-separy[rightbeg]
                    while (note>0){
                        if (begsLeftBoun[note]>0){
                              Lempty<-FALSE
                        }
                        note<-begsSepaNext[note]
                     }
                     #check whether right bound of left child is empty     
                     Rempty<-TRUE
                     note<-separy[leftbeg]
                     while (note>0){
                          if (begsRighBoun[note]>0){
                                 Rempty<-FALSE
                          }
                          note<-begsSepaNext[note]
                     }
                     #check whether one of boundaries is empty
                     if (Lempty || Rempty){
                             #one of boundaries is empty
############
#concatenating separate parts
#and updating boundaries for the separate parts
#separy[node]<- concatenate separy[leftbeg],separy[rightbeg]
###########
akku<-separy[leftbeg]
begsRighBoun[akku]<-0 #right boundaries of sets in left child are empty
                      # begsLeftBoun[akku] does not change
while (begsSepaNext[akku]>0){
  akku<-begsSepaNext[akku]
  begsRighBoun[akku]<-0
}                           
begsSepaNext[akku]<-separy[rightbeg] #concatenate list of separate sets
separy[node]<-separy[leftbeg]
akku<-separy[rightbeg]
begsLeftBoun[akku]<-0 #left boundaries of sets in right child are empty
while (begsSepaNext[akku]>0){
  akku<-begsSepaNext[akku]
  begsLeftBoun[akku]<-0
}        
####################
#end of concatenating
###################
                    }
                    else{  #both children exist, both boundaries non-empty  
jc<-joinconne(leftbeg,rightbeg,separy,
begsSepaNext,begsSepaBegs,begsLeftBoun,begsRighBoun,
atomsSepaNext,atomsSepaAtom,atomsLBounNext,atomsRBounNext,
direction,index)   #direction<-i
#
separy<-jc$separy
separy[node]<-jc$totbegSepary 
#
begsSepaNext<-jc$begsSepaNext
begsSepaBegs<-jc$begsSepaBegs
begsLeftBoun<-jc$begsLeftBoun
begsRighBoun<-jc$begsRighBoun
#
atomsSepaNext<-jc$atomsSepaNext
atomsSepaAtom<-jc$atomsSepaAtom
atomsLBounNext<-jc$atomsLBounNext
atomsRBounNext<-jc$atomsRBounNext
                        #
                    }
                } #toka else
            } #eka else
###########################################
#          end of child joining
###########################################
return(list(separy=separy,
begsSepaNext=begsSepaNext,begsSepaBegs=begsSepaBegs,
begsLeftBoun=begsLeftBoun,begsRighBoun=begsRighBoun,
atomsSepaNext=atomsSepaNext,atomsSepaAtom=atomsSepaAtom,
atomsLBounNext=atomsLBounNext,atomsRBounNext=atomsRBounNext))
}










kereva<-function(dendat,h,N,kernel="epane",trunc=3,threshold=0.0000001,
hw=NULL,weig=NULL)
{
#weig=rep(1/dim(dendat)[1],dim(dendat)[1]))

#source("~/kerle/profkernCRC.R")
#dyn.load("/home/jsk/kerle/kerCeva")
#dyn.load("/home/jsk/kerle/kerleCversio")
#pk2<-profkernCRC(dendat,h,N,Q)

#set.seed(seed=1)
#dendat<-matrix(rnorm(20),10)
#h<-1 
#N<-c(8,8)
#Q<-3

n<-dim(dendat)[1]
d<-dim(dendat)[2]  #length(N)

if (kernel=="gauss") h<-h*trunc   #trunc<-3

if (is.null(weig)) weig<-rep(1/n,n) 

if (!is.null(hw)){
   weig<-weightsit(n,hw)

   dendatnew<-dendat
   weignew<-weig
   cumul<-0
   for (i in 1:n){
        if (weig[i]>0){
            cumul<-cumul+1
            dendatnew[cumul,]<-dendat[i,]
            weignew[cumul]<-weig[i] 
        }
   }
   dendat<-dendatnew[1:cumul,]
   weig<-weignew[1:cumul]
   n<-cumul
}

inweig<-matrix(0,n+1,1)
inweig[2:(n+1)]<-weig

hnum<-length(h)
mnn<-maxnodenum(dendat,h,N,n,d)
extMaxnode<-mnn$maxnode
extMaxvals<-mnn$maxpositive
{
if (hnum>1){
 inh<-matrix(0,hnum+1,1)
 inh[2:(hnum+1)]<-h
}
else{
 inh<-h
}
}
inN<-matrix(0,d+1,1)
inN[2:(d+1)]<-N

if (kernel=="radon") kertype<-3
else if (kernel=="epane") kertype<-1 
else kertype<-2  # gaussian

kg<-.C("kergrid",
               as.integer(extMaxnode),
               as.integer(extMaxvals),
               as.double(dendat),
               as.double(inh),
               as.integer(inN),
               as.integer(n),
               as.integer(hnum),
               as.integer(d),
               as.integer(kertype),
               as.double(trunc),
               as.double(threshold),
               as.double(inweig),
               ioleft = integer(extMaxnode+1),
               ioright = integer(extMaxnode+1),
               ioparent = integer(extMaxnode+1),
               infopointer = integer(extMaxnode+1),
               iolow = integer(extMaxnode+1),
               ioupp = integer(extMaxnode+1),
               value = double(hnum*extMaxvals),
               index = integer(d*extMaxvals),
               nodefinder = integer(extMaxvals),
               numpositive = integer(1),
               numnode = integer(1),
PACKAGE = "denpro")

#left<-kg$ioleft[2:(kg$numnode+1)]
#right<-kg$ioright[2:(kg$numnode+1)]
#parent<-kg$ioparent[2:(kg$numnode+1)]
#infopointer<-kg$infopointer[2:(kg$numnode+1)]
#iolow<-kg$iolow[2:(kg$numnode+1)]
#ioupp<-kg$ioupp[2:(kg$numnode+1)]

value<-kg$value[2:(kg$numpositive+1)]
#nodefinder<-kg$nodefinder[2:(kg$numpositive+1)]
vecindex<-kg$index[2:(d*kg$numpositive+1)]
index<-matrix(0,kg$numpositive,d)
for (i in 1:kg$numpositive){
  for (j in 1:d){
     index[i,j]<-vecindex[(i-1)*d+j]
  }
}

#return(list(left=left,right=right,parent=parent,infopointer=infopointer,
#low=low,upp=upp,value=value,index=index,nodefinder=nodefinder))

suppo<-matrix(0,2*d,1)
for (i in 1:d){
   suppo[2*i-1]<-min(dendat[,i])-h
   suppo[2*i]<-max(dendat[,i])+h
}

step<-matrix(0,d,1)
for (i in 1:d) step[i]=(suppo[2*i]-suppo[2*i-1])/N[i];

recnum<-dim(index)[1]
low<-matrix(0,recnum,d)
upp<-matrix(0,recnum,d)
for (i in 1:recnum){
     low[i,]<-index[i,]-1
     upp[i,]<-index[i,]
}

return(list(value=value,index=index,
down=low,high=upp,N=N,step=step,support=suppo,n=n))

}
kergrid<-function(dendat,h,N){
#
#dendat is n*d- matrix of observations, 
#h is vector of positive smoothing parameters
#N is d-vector of the (dyadic) number of grid points for each direction
#
#dendat<-matrix(rnorm(20),10)
#h<-c(0.8,1,1.2)
#N<-c(4,4)
#
hnum<-length(h)
n<-dim(dendat)[1]
d<-dim(dendat)[2]
depth<-log(N,base=2)   
depoftree<-sum(depth)+1
#
minim<-matrix(0,d,1)  #minim is d-vector of minimums
maxim<-matrix(0,d,1)
for (i in 1:d){
  minim[i]<-min(dendat[,i])  
  maxim[i]<-max(dendat[,i])
}
hmax<-max(h)
delta<-(maxim-minim+2*hmax)/(N+1)
#
mindelta<-min(delta)
maxpositive<-n*(2*hmax/mindelta)^d
bigd<-sum(log(N,base=2))
maxnode<-bigd*ceiling(maxpositive)
#
numnode<-1
left<-matrix(0,maxnode,1)
right<-matrix(0,maxnode,1)
parent<-matrix(0,maxnode,1)
infopointer<-matrix(0,maxnode,1)
low<-matrix(0,maxnode,1)
low[1]<-1
upp<-matrix(0,maxnode,1)
upp[1]<-N[1]
#
numpositive<-0
value<-matrix(0,maxpositive,hnum)
index<-matrix(0,maxpositive,d)
nodefinder<-matrix(0,maxpositive,1)
#
gridlow<-matrix(0,d,1)
gridupp<-matrix(0,d,1)
#
for (i in 1:n){
 for (hrun in 1:hnum){ 
   #find the grid points in the support 
   for (j in 1:d){  
      gridlow[j]<-floor(((dendat[i,j]-minim[j])/delta[j])+1)
      gridupp[j]<-ceiling(((dendat[i,j]-minim[j]+2*h[hrun])/delta[j])-1)
   }
   base<-gridupp-gridlow+1
   gridcard<-prod(base)
   k<-0
   while (k<=(gridcard-1)){
      if (d>1){  
          inde<-digit(k,base)   #inde is d-vector
          inde<-inde+gridlow
      }
      else{
          inde<-gridlow+k
      }
      point<-minim-h[hrun]+delta*inde     #point is d-vector  
      val<-epane(point-dendat[i,],h[hrun])
      #find whether gridpoint is already in tree
      fe<-findend(inde,left,right,low,upp,N)
      if (fe$exists){
           pointer<-infopointer[fe$location]
           curval<-value[pointer,hrun]
           value[pointer,hrun]<-curval+val/n
      }
      else{  #gridpoint was not yet in the tree
         curre<-fe$location
         curdep<-fe$dep
         #
         ad<-addnode(inde,curre,curdep,left,right,parent,low,upp,N,numnode)
         numnode<-ad$numnode
         left<-ad$left
         right<-ad$right
         parent<-ad$parent
         low<-ad$low
         upp<-ad$upp
         nodeloc<-ad$nodeloc
         #
         numpositive<-numpositive+1
         infopointer[numnode]<-numpositive
         value[numpositive,hrun]<-val/n
         index[numpositive,]<-inde
         nodefinder[numpositive]<-nodeloc
      }
      k<-k+1 
   }
 }
}
left<-left[1:numnode]
right<-right[1:numnode]
parent<-parent[1:numnode]
infopointer<-infopointer[1:numnode]
#deplink<-deplink[1:numnode]
low<-low[1:numnode]
upp<-upp[1:numnode]
#
value<-value[1:numpositive,]
index<-index[1:numpositive,]
nodefinder<-nodefinder[1:numpositive]
return(list(left=left,right=right,parent=parent,infopointer=infopointer,
low=low,upp=upp,value=value,index=index,nodefinder=nodefinder))
}                              








leafsfirst.lst<-function(pcf, ngrid=NULL, predictor=NULL, type=NULL)
{
rho<-0

d<-length(pcf$N)
step<-matrix(0,d,1)
for (i in 1:d) step[i]<-(pcf$support[2*i]-pcf$support[2*i-1])/pcf$N[i]

lkm<-length(pcf$value)
distat<-pcf$value
infopointer<-seq(1,lkm)     # links from nodes to recs

distat<-distat[1:lkm]
infopointer<-infopointer[1:lkm]   
if (length(rho)==1) rho<-rep(rho,lkm)

# order the atoms for the level set with level "lev"

ord<-order(distat)
infopointer<-infopointer[ord]

# create tree

parent<-matrix(0,lkm,1)
child<-matrix(0,lkm,1)
sibling<-matrix(0,lkm,1)
volume<-matrix(0,lkm,1)
radius<-matrix(0,lkm,1)
ekamome<-matrix(0,lkm,d)
distcenter<-matrix(0,lkm,d)
branchradius<-matrix(0,lkm,1)

highestNext<-matrix(0,lkm,1)    #pointers to the nodes without parent
boundrec<-matrix(0,lkm,2*d) #for each node, the box which bounds all the c:dren

node<-lkm  #ord[lkm]  #the 1st child node is the one with the longest distance
parent[node]<-0
child[node]<-0
sibling[node]<-0

# radius
radius[node]<-distat[ord[node]]
branchradius[node]<-radius[node]

volume[node]<-1

beg<-node             #first without parent
highestNext[node]<-0
note<-infopointer[node]   #note<-pcf$nodefinder[infopointer[node]]
for (i in 1:d){
  boundrec[node,2*i-1]<-pcf$down[note,i]   
  boundrec[node,2*i]<-pcf$high[note,i]  
}

found.predictor.node<-FALSE
if ((!is.null(predictor))&&(!found.predictor.node)){
   predictor.rec<-matrix(0,2*d,1)
   for (ii in 1:d){ 
     predictor.rec[2*ii-1]<-floor((predictor[ii]-pcf$support[2*ii-1])/step[ii])
     predictor.rec[2*ii]<-ceiling((predictor[ii]-pcf$support[2*ii-1])/step[ii])
   }
   if (touch(predictor.rec,boundrec[node,])) predictor.node<-node
}
else predictor.node<-NULL

j<-2
while (j<=lkm){
    node<-lkm-j+1   #ord[lkm-j+1]

    # lisaa "node" ensimmaiseksi listaan
    highestNext[node]<-beg  #beg on listan tamanhetkinen ensimmainen
    beg<-node           

    # add node-singleton to boundrec
    rec1<-matrix(0,2*d,1)  #luo sigleton
    note<-infopointer[node]  #note<-pcf$nodefinder[infopointer[node]]
    for (i in 1:d){
         rec1[2*i-1]<-pcf$down[note,i]  
         rec1[2*i]<-pcf$high[note,i] 
    }
    boundrec[node,]<-rec1

    if ((!is.null(predictor))&&(!found.predictor.node)){
       if (touch(predictor.rec,boundrec[node,])) predictor.node<-node
    }

    # radius
    radius[node]<-distat[ord[node]]
    branchradius[node]<-radius[node]
    
    volume[node]<-1

    curroot<-highestNext[beg]  #node on 1., listassa ainakin 2
    prevroot<-beg
    ekatouch<-0
    while (curroot>0){
        rhocur<-rho[infopointer[node]]  
        istouch<-touchstep(node,curroot,boundrec,child,sibling,
                           infopointer,pcf$down,pcf$high,rhocur)
        if (istouch==1){
{
           # paivita parent, child, sibling, volume ekamome
           parent[curroot]<-node           
           if (ekatouch==0) ekatouch<-1 else ekatouch<-0 
           if (ekatouch==1){
              child[node]<-curroot
           }
           else{  # since ekatouch==0, prevroot>0
              sibling[lastsib]<-curroot
           }
           
           volume[node]<-volume[node]+volume[curroot]

           radius[node]<-min(distat[ord[node]],distat[ord[curroot]])
           if (branchradius[node]<=branchradius[curroot]) 
                  distcenter[node,]<-distcenter[curroot,]
           branchradius[node]<-max(branchradius[node],branchradius[curroot])

           # attach box of curroot
           rec1<-boundrec[node,]
           rec2<-boundrec[curroot,] 
           boundrec[node,]<-boundbox(rec1,rec2)
           # poista "curroot" listasta 
           highestNext[prevroot]<-highestNext[curroot]
}
        }     
        # if curroot was not removed, we update prevroot
        # else curroot was removed, we update lastsib
        if (istouch==0) prevroot<-curroot else lastsib<-curroot 
        curroot<-highestNext[curroot]
    }
    j<-j+1
}

root<-1 #ord[1]  #root is the barycenter

for (i in 1:lkm){
      for (j in 1:d){
          ekamome[i,j]<-ekamome[i,j]/volume[i]
      }
}
bary<-ekamome[root,]

level<-radius
maxdis<-distat[ord[length(ord)]]

lf<-list(
  parent=parent,volume=volume,center=t(ekamome),level=level,
  root=root,
  infopointer=infopointer,
  distcenter=t(distcenter),
  maxdis=maxdis,bary=bary,predictor.node=predictor.node)


# if ngrid given, reduce the lst
if (!is.null(ngrid)){
    stepsi<-maxdis/ngrid
    radii<-seq(0,maxdis,stepsi)
    lf<-treedisc(lf,pcf,r=radii,type=type)
}

return(lf)
}





leafsfirst.new<-function(pcf=NULL, lev=NULL, refe=NULL, type="lst",
levmet="radius", ordmet="etaisrec", ngrid=NULL,
dendat=NULL, rho=0, propor=NULL, dist.type="euclid")
{
# pcf is a piecewise constant object
# type= "lst"/"shape"
# levmet= "radius"/"proba"

if ((!is.null(lev)) || (!is.null(propor))) type<-"shape"
if (!is.null(dendat)) type<-"tail"

if (type=="tail") 

lst<-leafsfirst.tail(dendat=dendat, rho=rho, refe=refe, dist.type=dist.type)


return(lst)
}


leafsfirst.nn<-function(pcf=NULL,lev=NULL,refe=NULL,type="lst",levmet="radius",
ordmet="etaisrec",ngrid=NULL,
dendat=NULL,rho=0,propor=NULL)
{
# pcf is a piecewise constant object
# type= "lst"/"shape"
# levmet= "radius"/"proba"

if ((!is.null(lev)) || (!is.null(propor))){
    type<-"shape"
    if (!is.null(propor)) lev<-propor*max(pcf$value)
    if (is.null(refe)) refe<-locofmax(pcf)
}
if (!is.null(dendat)) type<-"tail"

if (type=="tail"){
   d<-dim(dendat)[2]
   pcf$high<-dendat+rho  #[infopointer[node]]  
   pcf$down<-dendat-rho 
   if (is.null(refe)){
       refe<-matrix(0,1,d)
       for (i in 1:d) refe[1,i]<-mean(dendat[,i])
       refe<-refe[1:d]
   }
}
else{
  d<-length(pcf$N)
  step<-matrix(0,d,1)
  for (i in 1:d) step[i]<-(pcf$support[2*i]-pcf$support[2*i-1])/pcf$N[i]
}

if (type=="lst"){
  lkm<-length(pcf$value)
  distat<-pcf$value
  infopointer<-seq(1,lkm)     # links from nodes to recs
}
else if (type=="shape"){
  lenni<-length(pcf$value)
  distat<-matrix(0,lenni,1)
  infopointer<-matrix(0,lenni,1)
  lkm<-0
  for (i in 1:lenni){
    if (pcf$value[i]>=lev){
       lkm<-lkm+1
       nod<-i  #nod<-pcf$nodefinder[i]
       if (ordmet=="etaisrec"){
           recci<-matrix(0,2*d,1)
           for (jj in 1:d){
              recci[2*jj-1]<-pcf$support[2*jj-1]+step[jj]*(pcf$down[nod,jj])
              recci[2*jj]<-pcf$support[2*jj-1]+step[jj]*pcf$high[nod,jj]
           }
           distat[lkm]<-etaisrec(refe,recci)
       }
       else{
          lowi<-matrix(0,d,1)
          uppi<-matrix(0,d,1)
          for (jj in 1:d){
             lowi[jj]<-pcf$support[2*jj-1]+step[jj]*(pcf$down[nod,jj])
             uppi[jj]<-pcf$support[2*jj-1]+step[jj]*pcf$high[nod,jj]
          }
          baryc<-lowi+(uppi-lowi)/2  
          distat[lkm]<-etais(baryc,refe)
       }
       infopointer[lkm]<-i
    }
  }
}
else{  #type=="tail"
   d<-dim(dendat)[2]
   n<-dim(dendat)[1]
   lkm<-dim(dendat)[1]
   distat<-sqrt(pituus(dendat-t(matrix(refe,d,n))))
   infopointer<-seq(1,lkm)
}

distat<-distat[1:lkm]
infopointer<-infopointer[1:lkm]   

# order the atoms for the level set with level "lev"

ord<-order(distat)
infopointer<-infopointer[ord]

# create tree

parent<-matrix(0,lkm,1)
child<-matrix(0,lkm,1)
sibling<-matrix(0,lkm,1)
volume<-matrix(0,lkm,1)
radius<-matrix(0,lkm,1)
proba<-matrix(0,lkm,1)
ekamome<-matrix(0,lkm,d)
distcenter<-matrix(0,lkm,d)
branchradius<-matrix(0,lkm,1)

highestNext<-matrix(0,lkm,1)    #pointers to the nodes without parent
boundrec<-matrix(0,lkm,2*d) #for each node, the box which bounds all the c:dren

node<-lkm  #ord[lkm]  #the 1st child node is the one with the longest distance
parent[node]<-0
child[node]<-0
sibling[node]<-0

# radius
radius[node]<-distat[ord[node]]
branchradius[node]<-radius[node]

if (type!="tail"){
  # volume calculation
  vol<-1
  k<-1
  ip<-infopointer[node]  #pcf$nodefinder[infopointer[node]]
  while (k<=d){
      vol<-vol*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
      k<-k+1
  }
  volume[node]<-vol
  ip2<-infopointer[node]
  proba[node]<-pcf$value[ip2]*vol

  # ekamome calculation
  newcente<-matrix(0,d,1)
  for (j in 1:d){
    volmin<-1
    k<-1
    while (k<=d){
       if (k!=j){
          volmin<-volmin*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
       }
       k<-k+1
    }
    ala<-pcf$support[2*j-1]+step[j]*pcf$down[ip,j]
    yla<-pcf$support[2*j-1]+step[j]*pcf$high[ip,j]
    newcente[j]<-volmin*(yla^2-ala^2)/2
  }
  ekamome[node,]<-newcente
  distcenter[node,]<-newcente/vol
}
else{
  volume[node]<-1
}

beg<-node             #first without parent
highestNext[node]<-0
note<-infopointer[node]   #note<-pcf$nodefinder[infopointer[node]]
for (i in 1:d){
  boundrec[node,2*i-1]<-pcf$down[note,i]   
  boundrec[node,2*i]<-pcf$high[note,i]  
}

j<-2
while (j<=lkm){
    node<-lkm-j+1   #ord[lkm-j+1]

    # lisaa "node" ensimmaiseksi listaan
    highestNext[node]<-beg  #beg on listan tamanhetkinen ensimmainen
    beg<-node           

    # add node-singleton to boundrec
    rec1<-matrix(0,2*d,1)  #luo sigleton
    note<-infopointer[node]  #note<-pcf$nodefinder[infopointer[node]]
    for (i in 1:d){
         rec1[2*i-1]<-pcf$down[note,i]  
         rec1[2*i]<-pcf$high[note,i] 
    }
    boundrec[node,]<-rec1

    # radius
    radius[node]<-distat[ord[node]]
    branchradius[node]<-radius[node]
    if (type!="tail"){
       # volume calculation
       vol<-1
       k<-1
       ip<-infopointer[node]    #pcf$nodefinder[infopointer[node]]
       while (k<=d){
          vol<-vol*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
          k<-k+1
       }
       volume[node]<-vol
       ip2<-infopointer[node]
       proba[node]<-pcf$value[ip2]*vol

       # ekamome calculation
       newcente<-matrix(0,d,1)
       for (jj in 1:d){
            volmin<-1
            k<-1
            while (k<=d){
               if (k!=jj){
                   volmin<-volmin*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
               }
               k<-k+1
            }
            ala<-pcf$support[2*jj-1]+step[jj]*pcf$down[ip,jj]
            yla<-pcf$support[2*jj-1]+step[jj]*pcf$high[ip,jj]
            newcente[jj]<-volmin*(yla^2-ala^2)/2
       }
       ekamome[node,]<-newcente
       distcenter[node,]<-newcente/vol
    }
    else{
       volume[node]<-1
    }

    curroot<-highestNext[beg]  #node on 1., listassa ainakin 2
    prevroot<-beg
    ekatouch<-0
    while (curroot>0){
        if (type=="tail") 
            istouch<-touchstep.tail(node,curroot,boundrec,child,sibling,
                                    infopointer,pcf$down,pcf$high) 
        else istouch<-touchstep(node,curroot,boundrec,child,sibling,
                           infopointer,pcf$down,pcf$high)
        if (istouch==1){

           # paivita parent, child, sibling, volume ekamome
           parent[curroot]<-node           
           if (ekatouch==0) ekatouch<-1 else ekatouch<-0 
           if (ekatouch==1){
              child[node]<-curroot
           }
           else{  # since ekatouch==0, prevroot>0
              sibling[lastsib]<-curroot
           }
           if (type!="tail"){
              volume[node]<-volume[node]+volume[curroot]
              proba[node]<-proba[node]+proba[curroot]
              ekamome[node,]<-ekamome[node,]+ekamome[curroot,]
           }
           else{
              volume[node]<-volume[node]+volume[curroot]
           }

           radius[node]<-min(distat[ord[node]],distat[ord[curroot]])
           if (branchradius[node]<=branchradius[curroot]) 
                  distcenter[node,]<-distcenter[curroot,]
           branchradius[node]<-max(branchradius[node],branchradius[curroot])

           # attach box of curroot
           rec1<-boundrec[node,]
           rec2<-boundrec[curroot,] 
           boundrec[node,]<-boundbox(rec1,rec2)
           # poista "curroot" listasta 
           highestNext[prevroot]<-highestNext[curroot]

        }     
        # if curroot was not removed, we update prevroot
        # else curroot was removed, we update lastsib
        if (istouch==0) prevroot<-curroot else lastsib<-curroot 
        curroot<-highestNext[curroot]
    }
    j<-j+1
}

root<-1 #ord[1]  #root is the barycenter
# lf is the level set tree or the shape tree
if (type!="tail"){
   for (i in 1:lkm){
      for (j in 1:d){
          ekamome[i,j]<-ekamome[i,j]/volume[i]
      }
   }
   bary<-ekamome[root,]
}
if (type=="shape"){
  maxdis<-sqrt(distat[ord[length(ord)]])
  if (levmet=="proba")
     level<-taillevel(root,#child,sibling,
            parent,volume,proba)
  else 
     level<-sqrt(radius)
}
else{ #type="lst"
     level<-radius
     maxdis<-distat[ord[length(ord)]]
}
if (type=="tail"){
   center<-t(dendat[infopointer,])
}

if (type!="tail"){
  lf<-list(
  parent=parent,volume=volume,center=t(ekamome),level=level,
  root=root,
  #child=child,sibling=sibling,  #virhe??
  infopointer=infopointer,
  proba=proba,#radius=radius,
  #branchradius=sqrt(branchradius),
  distcenter=t(distcenter),
  refe=refe,maxdis=maxdis,bary=bary,lev=lev)
}
else{
  lf<-list(
  parent=parent,volume=volume,center=center,level=level,
  root=root,
  #child=child,sibling=sibling,  #virhe??
  infopointer=infopointer,
  #proba=proba,#radius=radius,
  #branchradius=sqrt(branchradius),
  #distcenter=t(distcenter),
  refe=refe,maxdis=maxdis,
  dendat=dendat)
}

# if ngrid given, reduce the lst
if (!is.null(ngrid)){
    stepsi<-maxdis/ngrid
    radii<-seq(0,maxdis,stepsi)
    lf<-treedisc(lf,pcf,r=radii,type=type)
}

return(lf)
}





leafsfirst<-function(pcf=NULL,lev=NULL,refe=NULL,type="lst",levmet="radius",
ordmet="etaisrec",ngrid=NULL,
dendat=NULL,rho=0,propor=NULL,lowest="dens")
{
# pcf is a piecewise constant object
# type= "lst"/"shape"
# levmet= "radius"/"proba"

if (lowest=="dens") lowest<-0 else lowest<-min(pcf$value)

if ((!is.null(lev)) || (!is.null(propor))){
    type<-"shape"
    if (!is.null(propor)) lev<-propor*max(pcf$value)
    if (is.null(refe)) refe<-locofmax(pcf)
}
if (!is.null(dendat)) type<-"tail"

if (type=="tail"){
   d<-dim(dendat)[2]
   pcf$high<-dendat
   pcf$down<-dendat
   if (is.null(refe)){
       refe<-matrix(0,1,d)
       for (i in 1:d) refe[1,i]<-mean(dendat[,i])
       refe<-refe[1:d]
   }
}
else{
  d<-length(pcf$N)
  step<-matrix(0,d,1)
  for (i in 1:d) step[i]<-(pcf$support[2*i]-pcf$support[2*i-1])/pcf$N[i]
}

if (type=="lst"){
  lkm<-length(pcf$value)
  distat<-pcf$value-lowest
  infopointer<-seq(1,lkm)     # links from nodes to recs
}
else if (type=="shape"){
  lenni<-length(pcf$value)
  distat<-matrix(0,lenni,1)
  infopointer<-matrix(0,lenni,1)
  lkm<-0
  for (i in 1:lenni){
    if (pcf$value[i]>=lev){
       lkm<-lkm+1
       nod<-i  #nod<-pcf$nodefinder[i]
       if (ordmet=="etaisrec"){
           recci<-matrix(0,2*d,1)
           for (jj in 1:d){
              recci[2*jj-1]<-pcf$support[2*jj-1]+step[jj]*(pcf$down[nod,jj])
              recci[2*jj]<-pcf$support[2*jj-1]+step[jj]*pcf$high[nod,jj]
           }
           distat[lkm]<-etaisrec(refe,recci)
       }
       else{
          lowi<-matrix(0,d,1)
          uppi<-matrix(0,d,1)
          for (jj in 1:d){
             lowi[jj]<-pcf$support[2*jj-1]+step[jj]*(pcf$down[nod,jj])
             uppi[jj]<-pcf$support[2*jj-1]+step[jj]*pcf$high[nod,jj]
          }
          baryc<-lowi+(uppi-lowi)/2  
          distat[lkm]<-etais(baryc,refe)
       }
       infopointer[lkm]<-i
    }
  }
}
else{  #type=="tail"
   d<-dim(dendat)[2]
   n<-dim(dendat)[1]
   lkm<-dim(dendat)[1]
   distat<-sqrt(pituus(dendat-t(matrix(refe,d,n))))
   infopointer<-seq(1,lkm)
}

distat<-distat[1:lkm]
infopointer<-infopointer[1:lkm]   
#if (length(rho)==1) rho<-rep(rho,lkm)

# order the atoms for the level set with level "lev"

ord<-order(distat)
infopointer<-infopointer[ord]

# create tree

parent<-matrix(0,lkm,1)
child<-matrix(0,lkm,1)
sibling<-matrix(0,lkm,1)
volume<-matrix(0,lkm,1)
radius<-matrix(0,lkm,1)
proba<-matrix(0,lkm,1)
ekamome<-matrix(0,lkm,d)
distcenter<-matrix(0,lkm,d)
branchradius<-matrix(0,lkm,1)

highestNext<-matrix(0,lkm,1)    #pointers to the nodes without parent
boundrec<-matrix(0,lkm,2*d) #for each node, the box which bounds all the c:dren

node<-lkm  #ord[lkm]  #the 1st child node is the one with the longest distance
parent[node]<-0
child[node]<-0
sibling[node]<-0

# radius
radius[node]<-distat[ord[node]]
branchradius[node]<-radius[node]

if (type!="tail"){
  # volume calculation
  vol<-1
  k<-1
  ip<-infopointer[node]  #pcf$nodefinder[infopointer[node]]
  while (k<=d){
      vol<-vol*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
      k<-k+1
  }
  volume[node]<-vol
  ip2<-infopointer[node]
  proba[node]<-pcf$value[ip2]*vol

  # ekamome calculation
  newcente<-matrix(0,d,1)
  for (j in 1:d){
    volmin<-1
    k<-1
    while (k<=d){
       if (k!=j){
          volmin<-volmin*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
       }
       k<-k+1
    }
    ala<-pcf$support[2*j-1]+step[j]*pcf$down[ip,j]
    yla<-pcf$support[2*j-1]+step[j]*pcf$high[ip,j]
    newcente[j]<-volmin*(yla^2-ala^2)/2
  }
  ekamome[node,]<-newcente
  distcenter[node,]<-newcente/vol
}
else{
  volume[node]<-1
}

beg<-node             #first without parent
highestNext[node]<-0
note<-infopointer[node]   #note<-pcf$nodefinder[infopointer[node]]
for (i in 1:d){
  boundrec[node,2*i-1]<-pcf$down[note,i]   
  boundrec[node,2*i]<-pcf$high[note,i]  
}

j<-2
while (j<=lkm){
    node<-lkm-j+1   #ord[lkm-j+1]

    # lisaa "node" ensimmaiseksi listaan
    highestNext[node]<-beg  #beg on listan tamanhetkinen ensimmainen
    beg<-node           

    # add node-singleton to boundrec
    rec1<-matrix(0,2*d,1)  #luo sigleton
    note<-infopointer[node]  #note<-pcf$nodefinder[infopointer[node]]
    for (i in 1:d){
         rec1[2*i-1]<-pcf$down[note,i]  
         rec1[2*i]<-pcf$high[note,i] 
    }
    boundrec[node,]<-rec1

    # radius
    radius[node]<-distat[ord[node]]
    branchradius[node]<-radius[node]
    if (type!="tail"){
       # volume calculation
       vol<-1
       k<-1
       ip<-infopointer[node]    #pcf$nodefinder[infopointer[node]]
       while (k<=d){
          vol<-vol*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
          k<-k+1
       }
       volume[node]<-vol
       ip2<-infopointer[node]
       proba[node]<-pcf$value[ip2]*vol

       # ekamome calculation
       newcente<-matrix(0,d,1)
       for (jj in 1:d){
            volmin<-1
            k<-1
            while (k<=d){
               if (k!=jj){
                   volmin<-volmin*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
               }
               k<-k+1
            }
            ala<-pcf$support[2*jj-1]+step[jj]*pcf$down[ip,jj]
            yla<-pcf$support[2*jj-1]+step[jj]*pcf$high[ip,jj]
            newcente[jj]<-volmin*(yla^2-ala^2)/2
       }
       ekamome[node,]<-newcente
       distcenter[node,]<-newcente/vol
    }
    else{
       volume[node]<-1
    }

    curroot<-highestNext[beg]  #node on 1., listassa ainakin 2
    prevroot<-beg
    ekatouch<-0
    while (curroot>0){
        rhocur<-rho   #rho[infopointer[node]]  
        istouch<-touchstep(node,curroot,boundrec,child,sibling,
                           infopointer,pcf$down,pcf$high,rhocur)
        if (istouch==1){
{
           # paivita parent, child, sibling, volume ekamome
           parent[curroot]<-node           
           if (ekatouch==0) ekatouch<-1 else ekatouch<-0 
           if (ekatouch==1){
              child[node]<-curroot
           }
           else{  # since ekatouch==0, prevroot>0
              sibling[lastsib]<-curroot
           }
           if (type!="tail"){
              volume[node]<-volume[node]+volume[curroot]
              proba[node]<-proba[node]+proba[curroot]
              ekamome[node,]<-ekamome[node,]+ekamome[curroot,]
           }
           else{
              volume[node]<-volume[node]+volume[curroot]
           }

           radius[node]<-min(distat[ord[node]],distat[ord[curroot]])
           if (branchradius[node]<=branchradius[curroot]) 
                  distcenter[node,]<-distcenter[curroot,]
           branchradius[node]<-max(branchradius[node],branchradius[curroot])

           # attach box of curroot
           rec1<-boundrec[node,]
           rec2<-boundrec[curroot,] 
           boundrec[node,]<-boundbox(rec1,rec2)
           # poista "curroot" listasta 
           highestNext[prevroot]<-highestNext[curroot]
}
        }     
        # if curroot was not removed, we update prevroot
        # else curroot was removed, we update lastsib
        if (istouch==0) prevroot<-curroot else lastsib<-curroot 
        curroot<-highestNext[curroot]
    }
    j<-j+1
}

root<-1 #ord[1]  #root is the barycenter
# lf is the level set tree or the shape tree
if (type!="tail"){
   for (i in 1:lkm){
      for (j in 1:d){
          ekamome[i,j]<-ekamome[i,j]/volume[i]
      }
   }
   bary<-ekamome[root,]
}
if (type=="shape"){
  maxdis<-sqrt(distat[ord[length(ord)]])
  if (levmet=="proba")
     level<-taillevel(root,#child,sibling,
            parent,volume,proba)
  else 
     level<-sqrt(radius)
}
else{ #type="lst"
     level<-radius+lowest
     maxdis<-distat[ord[length(ord)]]
}
if (type=="tail"){
   center<-t(dendat[infopointer,])
}

if (type!="tail"){
  lf<-list(
  parent=parent,volume=volume,center=t(ekamome),level=level,
  root=root,
  #child=child,sibling=sibling,  #virhe??
  infopointer=infopointer,
  proba=proba,#radius=radius,
  #branchradius=sqrt(branchradius),
  distcenter=t(distcenter),
  refe=refe,maxdis=maxdis,bary=bary,lev=lev)
}
else{
  lf<-list(
  parent=parent,volume=volume,center=center,level=level,
  root=root,
  #child=child,sibling=sibling,  #virhe??
  infopointer=infopointer,
  #proba=proba,#radius=radius,
  #branchradius=sqrt(branchradius),
  #distcenter=t(distcenter),
  refe=refe,maxdis=maxdis,
  dendat=dendat)
}

# if ngrid given, reduce the lst
if (!is.null(ngrid)){
    stepsi<-maxdis/ngrid
    radii<-seq(0,maxdis,stepsi)
    lf<-treedisc(lf,pcf,r=radii,type=type)
}

return(lf)
}





leafsfirst.shape<-function(pcf=NULL, lev=NULL, refe=NULL, levmet="radius",
ordmet="etaisrec", propor=NULL)
{
rho<-0

if (!is.null(propor)) lev<-propor*max(pcf$value)
if (is.null(refe)) refe<-locofmax(pcf)

d<-length(pcf$N)
step<-matrix(0,d,1)
for (i in 1:d) step[i]<-(pcf$support[2*i]-pcf$support[2*i-1])/pcf$N[i]

  lenni<-length(pcf$value)
  distat<-matrix(0,lenni,1)
  infopointer<-matrix(0,lenni,1)
  lkm<-0
  for (i in 1:lenni){
    if (pcf$value[i]>=lev){
       lkm<-lkm+1
       nod<-i  #nod<-pcf$nodefinder[i]
       if (ordmet=="etaisrec"){
           recci<-matrix(0,2*d,1)
           for (jj in 1:d){
              recci[2*jj-1]<-pcf$support[2*jj-1]+step[jj]*(pcf$down[nod,jj])
              recci[2*jj]<-pcf$support[2*jj-1]+step[jj]*pcf$high[nod,jj]
           }
           distat[lkm]<-etaisrec(refe,recci)
       }
       else{
          lowi<-matrix(0,d,1)
          uppi<-matrix(0,d,1)
          for (jj in 1:d){
             lowi[jj]<-pcf$support[2*jj-1]+step[jj]*(pcf$down[nod,jj])
             uppi[jj]<-pcf$support[2*jj-1]+step[jj]*pcf$high[nod,jj]
          }
          baryc<-lowi+(uppi-lowi)/2  
          distat[lkm]<-etais(baryc,refe)
       }
       infopointer[lkm]<-i
    }
  }

distat<-distat[1:lkm]
infopointer<-infopointer[1:lkm]   
#if (length(rho)==1) rho<-rep(rho,lkm)

# order the atoms for the level set with level "lev"

ord<-order(distat)
infopointer<-infopointer[ord]

# create tree

parent<-matrix(0,lkm,1)
child<-matrix(0,lkm,1)
sibling<-matrix(0,lkm,1)
volume<-matrix(0,lkm,1)
radius<-matrix(0,lkm,1)
proba<-matrix(0,lkm,1)
ekamome<-matrix(0,lkm,d)
distcenter<-matrix(0,lkm,d)
branchradius<-matrix(0,lkm,1)

highestNext<-matrix(0,lkm,1)    #pointers to the nodes without parent
boundrec<-matrix(0,lkm,2*d) #for each node, the box which bounds all the c:dren

node<-lkm  #ord[lkm]  #the 1st child node is the one with the longest distance
parent[node]<-0
child[node]<-0
sibling[node]<-0

# radius
radius[node]<-distat[ord[node]]
branchradius[node]<-radius[node]


  # volume calculation
  vol<-1
  k<-1
  ip<-infopointer[node]  #pcf$nodefinder[infopointer[node]]
  while (k<=d){
      vol<-vol*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
      k<-k+1
  }
  volume[node]<-vol
  ip2<-infopointer[node]
  proba[node]<-pcf$value[ip2]*vol

  # ekamome calculation
  newcente<-matrix(0,d,1)
  for (j in 1:d){
    volmin<-1
    k<-1
    while (k<=d){
       if (k!=j){
          volmin<-volmin*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
       }
       k<-k+1
    }
    ala<-pcf$support[2*j-1]+step[j]*pcf$down[ip,j]
    yla<-pcf$support[2*j-1]+step[j]*pcf$high[ip,j]
    newcente[j]<-volmin*(yla^2-ala^2)/2
  }
  ekamome[node,]<-newcente
  distcenter[node,]<-newcente/vol

beg<-node             #first without parent
highestNext[node]<-0
note<-infopointer[node]   #note<-pcf$nodefinder[infopointer[node]]
for (i in 1:d){
  boundrec[node,2*i-1]<-pcf$down[note,i]   
  boundrec[node,2*i]<-pcf$high[note,i]  
}

j<-2
while (j<=lkm){
    node<-lkm-j+1   #ord[lkm-j+1]

    # lisaa "node" ensimmaiseksi listaan
    highestNext[node]<-beg  #beg on listan tamanhetkinen ensimmainen
    beg<-node           

    # add node-singleton to boundrec
    rec1<-matrix(0,2*d,1)  #luo sigleton
    note<-infopointer[node]  #note<-pcf$nodefinder[infopointer[node]]
    for (i in 1:d){
         rec1[2*i-1]<-pcf$down[note,i]  
         rec1[2*i]<-pcf$high[note,i] 
    }
    boundrec[node,]<-rec1

    # radius
    radius[node]<-distat[ord[node]]
    branchradius[node]<-radius[node]

       # volume calculation
       vol<-1
       k<-1
       ip<-infopointer[node]    #pcf$nodefinder[infopointer[node]]
       while (k<=d){
          vol<-vol*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
          k<-k+1
       }
       volume[node]<-vol
       ip2<-infopointer[node]
       proba[node]<-pcf$value[ip2]*vol

       # ekamome calculation
       newcente<-matrix(0,d,1)
       for (jj in 1:d){
            volmin<-1
            k<-1
            while (k<=d){
               if (k!=jj){
                   volmin<-volmin*(pcf$high[ip,k]-pcf$down[ip,k])*step[k]
               }
               k<-k+1
            }
            ala<-pcf$support[2*jj-1]+step[jj]*pcf$down[ip,jj]
            yla<-pcf$support[2*jj-1]+step[jj]*pcf$high[ip,jj]
            newcente[jj]<-volmin*(yla^2-ala^2)/2
       }
       ekamome[node,]<-newcente
       distcenter[node,]<-newcente/vol

    curroot<-highestNext[beg]  #node on 1., listassa ainakin 2
    prevroot<-beg
    ekatouch<-0
    while (curroot>0){
      
        istouch<-touchstep(node,curroot,boundrec,child,sibling,
                           infopointer,pcf$down,pcf$high,rho)
        if (istouch==1){
{
           # paivita parent, child, sibling, volume ekamome
           parent[curroot]<-node           
           if (ekatouch==0) ekatouch<-1 else ekatouch<-0 
           if (ekatouch==1){
              child[node]<-curroot
           }
           else{  # since ekatouch==0, prevroot>0
              sibling[lastsib]<-curroot
           }

              volume[node]<-volume[node]+volume[curroot]
              proba[node]<-proba[node]+proba[curroot]
              ekamome[node,]<-ekamome[node,]+ekamome[curroot,]

           radius[node]<-min(distat[ord[node]],distat[ord[curroot]])
           if (branchradius[node]<=branchradius[curroot]) 
                  distcenter[node,]<-distcenter[curroot,]
           branchradius[node]<-max(branchradius[node],branchradius[curroot])

           # attach box of curroot
           rec1<-boundrec[node,]
           rec2<-boundrec[curroot,] 
           boundrec[node,]<-boundbox(rec1,rec2)
           # poista "curroot" listasta 
           highestNext[prevroot]<-highestNext[curroot]
}
        }     
        # if curroot was not removed, we update prevroot
        # else curroot was removed, we update lastsib
        if (istouch==0) prevroot<-curroot else lastsib<-curroot 
        curroot<-highestNext[curroot]
    }
    j<-j+1
}

root<-1 #ord[1]  #root is the barycenter
# lf is the level set tree or the shape tree

   for (i in 1:lkm){
      for (j in 1:d){
          ekamome[i,j]<-ekamome[i,j]/volume[i]
      }
   }
   bary<-ekamome[root,]

  maxdis<-sqrt(distat[ord[length(ord)]])
  if (levmet=="proba")
     level<-taillevel(root,#child,sibling,
            parent,volume,proba)
  else 
     level<-sqrt(radius)

  lf<-list(
  parent=parent,volume=volume,center=t(ekamome),level=level,
  root=root,
  #child=child,sibling=sibling,  #virhe??
  infopointer=infopointer,
  proba=proba,#radius=radius,
  #branchradius=sqrt(branchradius),
  distcenter=t(distcenter),
  refe=refe,maxdis=maxdis,bary=bary,lev=lev)

return(lf)
}

leafsfirst.tail<-function(dendat, rho=0, refe=NULL, dist.type="euclid")
{

n<-dim(dendat)[1]
d<-dim(dendat)[2]
pcfhigh<-dendat+rho
pcfdown<-dendat-rho
if (is.null(refe)){
      refe<-matrix(0,1,d)
      for (i in 1:d) refe[1,i]<-mean(dendat[,i])
      refe<-refe[1:d]
}

distat<-sqrt(pituus(dendat-t(matrix(refe,d,n))))
lkm<-n
infopointer<-seq(1,lkm)
if (length(rho)==1) rho<-rep(rho,lkm)

# order the atoms for the level set with level "lev"

ord<-order(distat)
infopointer<-infopointer[ord]

# create tree

parent<-matrix(0,lkm,1)
child<-matrix(0,lkm,1)
sibling<-matrix(0,lkm,1)
volume<-matrix(0,lkm,1)
radius<-matrix(0,lkm,1)

highestNext<-matrix(0,lkm,1)    #pointers to the nodes without parent
boundrec<-matrix(0,lkm,2*d) #for each node, the box which bounds all the c:dren

node<-lkm  #ord[lkm]  #the 1st child node is the one with the longest distance
parent[node]<-0
child[node]<-0
sibling[node]<-0

# radius
radius[node]<-distat[ord[node]]

volume[node]<-1

beg<-node                 #first without parent
highestNext[node]<-0
note<-infopointer[node]   #note<-pcf$nodefinder[infopointer[node]]
for (i in 1:d){
  boundrec[node,2*i-1]<-pcfdown[note,i]   
  boundrec[node,2*i]<-pcfhigh[note,i]  
}

j<-2
while (j<=lkm){
    node<-lkm-j+1   #ord[lkm-j+1]

    # lisaa "node" ensimmaiseksi listaan
    highestNext[node]<-beg  #beg on listan tamanhetkinen ensimmainen
    beg<-node           

    # add node-singleton to boundrec
    rec1<-matrix(0,2*d,1)  #luo sigleton
    note<-infopointer[node]  #note<-pcf$nodefinder[infopointer[node]]
    for (i in 1:d){
         rec1[2*i-1]<-pcfdown[note,i]  
         rec1[2*i]<-pcfhigh[note,i] 
    }
    boundrec[node,]<-rec1

    # radius
    radius[node]<-distat[ord[node]]

    volume[node]<-1

    curroot<-highestNext[beg]  #node on 1., listassa ainakin 2
    prevroot<-beg
    ekatouch<-0
    while (curroot>0){
        #rhocur<-rho[infopointer[node]]  
        istouch<-touchstep.tail(node,curroot,boundrec,child,sibling,
                                infopointer,pcfdown,pcfhigh,rho,dendat,
                                dist.type=dist.type)
        if (istouch==1){

           # paivita parent, child, sibling, volume 
           parent[curroot]<-node           
           if (ekatouch==0) ekatouch<-1 else ekatouch<-0 
           if (ekatouch==1){
              child[node]<-curroot
           }
           else{  # since ekatouch==0, prevroot>0
              sibling[lastsib]<-curroot
           }

           volume[node]<-volume[node]+volume[curroot]

           radius[node]<-min(distat[ord[node]],distat[ord[curroot]])

           # attach box of curroot
           rec1<-boundrec[node,]
           rec2<-boundrec[curroot,] 
           boundrec[node,]<-boundbox(rec1,rec2)
           # poista "curroot" listasta 
           highestNext[prevroot]<-highestNext[curroot]

        }     
        # if curroot was not removed, we update prevroot
        # else curroot was removed, we update lastsib
        if (istouch==0) prevroot<-curroot else lastsib<-curroot 
        curroot<-highestNext[curroot]
    }
    j<-j+1
}

root<-1 #ord[1]  #root is the barycenter

maxdis<-distat[ord[length(ord)]]
center<-t(dendat[infopointer,])

lf<-list(
parent=parent,volume=volume,center=center,level=radius,
root=root,
infopointer=infopointer,
refe=refe,maxdis=maxdis,
dendat=dendat)

return(lf)
}






leafsfirst.visu<-function(tt,pcf,lev=NULL,refe=NULL,type="lst",
levmet="radius",ordmet="etaisrec",
lkmbound=NULL,radius=NULL,
orde="furthest",suppo=T,propor=NULL,lty=NULL,numbers=TRUE,
sigcol="lightblue",cex.axis=1,cex=1)
{

if ((!is.null(lev)) || (!is.null(propor))){
    type<-"shape"
    if (is.null(refe)) refe<-locofmax(pcf)
    if (!is.null(propor)) lev<-propor*max(pcf$value)
}
if (is.null(refe)) refe<-locofmax(pcf)

pp<-plotprof(tt,plot=FALSE,data=TRUE)
vecs<-pp$vecs

d<-length(pcf$N)
step<-matrix(0,d,1)
for (i in 1:d) step[i]<-(pcf$support[2*i]-pcf$support[2*i-1])/pcf$N[i]

# order the atoms for the level set with level "lev"

lenni<-length(pcf$value)
distat<-matrix(0,lenni,1)
infopointer<-matrix(0,lenni,1)

if (type=="lst"){
  lkm<-lenni
  distat<-pcf$value
  infopointer<-seq(1,lkm)
}
else{

lkm<-0
for (i in 1:lenni){
  if (pcf$value[i]>=lev){
     lkm<-lkm+1
     nod<-i  #nod<-pcf$nodefinder[i]
     if (ordmet=="etaisrec"){
         recci<-matrix(0,2*d,1)
         for (jj in 1:d){
            recci[2*jj-1]<-pcf$support[2*jj-1]+step[jj]*pcf$down[nod,jj]
            recci[2*jj]<-pcf$support[2*jj-1]+step[jj]*pcf$high[nod,jj]
         }
         distat[lkm]<-etaisrec(refe,recci)
     }
     else{
         lowi<-matrix(0,d,1)
         uppi<-matrix(0,d,1)
         for (jj in 1:d){
            lowi[jj]<-pcf$support[2*jj-1]+step[jj]*pcf$down[nod,jj]
            uppi[jj]<-pcf$support[2*jj-1]+step[jj]*pcf$high[nod,jj]
         }
         baryc<-lowi+(uppi-lowi)/2
         distat[lkm]<-etais(baryc,refe)  #etais(baryc[lk m,],baryind)
     }
     infopointer[lkm]<-i
  }
}

}  #else

distat<-distat[1:lkm]
infopointer<-infopointer[1:lkm]   #pointe->pcf$value,pcf$nodefinder

ord<-order(distat)
infopointer<-infopointer[ord]

if (suppo){
  xmin<-pcf$support[1]
  xmax<-pcf$support[2]
  ymin<-pcf$support[3]
  ymax<-pcf$support[4]
}
else{
  xmin<-tt$refe[1]-tt$maxdis  #pcf$support[1]
  xmax<-tt$refe[1]+tt$maxdis  #pcf$support[2]
  ymin<-tt$refe[1]-tt$maxdis  #pcf$support[3]
  ymax<-tt$refe[2]+tt$maxdis  #pcf$support[4]
}

plot(x=refe[1],y=refe[2],xlab="",ylab="",xlim=c(xmin,xmax),ylim=c(ymin,ymax),
pch=20,cex.axis=cex.axis) #,col="red")

i<-1
while (i<=lkm){

     if (orde=="furthest") node<-lkm-i+1 else node<-i
     ip<-infopointer[node]   #ip<-pcf$nodefinder[infopointer[node]]

     x1<-pcf$support[1]+step[1]*pcf$down[ip,1]
     x2<-pcf$support[1]+step[1]*pcf$high[ip,1] 
     y1<-pcf$support[3]+step[2]*pcf$down[ip,2]
     y2<-pcf$support[3]+step[2]*pcf$high[ip,2] 
     polygon(c(x1,x2,x2,x1),c(y1,y1,y2,y2),col="gray",lty=lty)

     i<-i+1
}

if (!is.null(lkmbound)){
  i<-1
  while (i<=lkmbound){

     if (orde=="furthest") node<-lkm-i+1 else node<-i
     ip<-infopointer[node]  #ip<-pcf$nodefinder[infopointer[node]]

     x1<-pcf$support[1]+step[1]*pcf$down[ip,1]
     x2<-pcf$support[1]+step[1]*pcf$high[ip,1] 
     y1<-pcf$support[3]+step[2]*pcf$down[ip,2]
     y2<-pcf$support[3]+step[2]*pcf$high[ip,2] 
     dev.set(which = dev.next())
     polygon(c(x1,x2,x2,x1),c(y1,y1,y2,y2),col=sigcol,lty=lty)
     #points(x=refe[1],y=refe[2],pch=20,col="red")
     if (numbers) text(x=x1+(x2-x1)/2,y=y1+(y2-y1)/2,paste(i),cex=cex)

     i<-i+1
  }
}
else{
  i<-1
  radu<-tt$level[lkm]  #tt$madxdis
  while (radu>=radius){

     if (orde=="furthest") node<-lkm-i+1 else node<-i
     ip<-infopointer[node]  #ip<-pcf$nodefinder[infopointer[node]]

     x1<-pcf$support[1]+step[1]*pcf$down[ip,1]
     x2<-pcf$support[1]+step[1]*pcf$high[ip,1] 
     y1<-pcf$support[3]+step[2]*pcf$down[ip,2]
     y2<-pcf$support[3]+step[2]*pcf$high[ip,2] 
     dev.set(which = dev.next())
     polygon(c(x1,x2,x2,x1),c(y1,y1,y2,y2),col="blue",lty=lty)
     points(x=refe[1],y=refe[2],pch=20,col="red")

     i<-i+1
     radu<-tt$level[node]
  }
}

}

leikkaa<-function(rec1,rec2){
#Makes an intersection of rectangles rec1, rec2
#rec1,rec2 are 2*d vectors
#
#Returns 2*d-vector or NA if intersection is empty
#
d<-length(rec1)/2
tulos<-matrix(0,2*d,1)
i<-1
while ((i<=d) && (!is.na(tulos))){  
    tulos[2*i-1]<-max(rec1[2*i-1],rec2[2*i-1])
    tulos[2*i]<-min(rec1[2*i],rec2[2*i])
    if (tulos[2*i]<=tulos[2*i-1]) tulos<-NA
    i<-i+1
}
return(tulos)
}

levord<-function(beg,sibling,sibord,centers,crit){
#order at the given level
#
# find first
#
itemnum<-length(sibling)
diffe<-matrix(NA,itemnum,1)    #NA is infty
cur<-beg
curre<-centers[,cur]
diffe[cur]<-etais(curre,crit)
sibnum<-1   #if beg has no siblings, then sibnum=1 (beg is its own sibling)
while (sibling[cur]>0){
     cur<-sibling[cur] 
     curre<-centers[,cur]
     diffe[cur]<-etais(curre,crit)
     sibnum<-sibnum+1
}
first<-omaind(-diffe)
#sibord[first]<-1
#
# find distances to first
#
firstcenter<-centers[,first]
distofir<-matrix(NA,itemnum,1)
cur<-beg
curre<-centers[,cur]
distofir[cur]<-etais(curre,firstcenter)
while (sibling[cur]>0){
    cur<-sibling[cur]
    curre<-centers[,cur]
    distofir[cur]<-etais(curre,firstcenter)
}
#  
# fill sibord in the order of closest to first 
#
ind<-1
remain<-sibnum
while (remain>0){  
     nex<-omaind(distofir)
     sibord[nex]<-ind
     distofir[nex]<-NA 
     ind<-ind+1
     remain<-remain-1     
}
return(sibord)
}











liketree<-function(dendat,pcf,lst)
{

# "lst$infopointer" gives links from nodes to recs
# invert the links
rnum<-length(pcf$value)
nodefinder<-matrix(0,rnum,1)
for (i in 1:rnum) nodefinder[lst$infopointer[i]]<-i

n<-dim(dendat)[1]
d<-dim(dendat)[2]

step<-matrix(0,d,1)
for (i in 1:d) step[i]<-(pcf$support[2*i]-pcf$support[2*i-1])/pcf$N[i]

# find links from dendat to pcf
# (for simplicity we delete multiple observations in a bin
den2pcf<-matrix(0,n,1)
pcf2den<-matrix(0,rnum,1)
varauslista<-matrix(0,rnum,1)
dendat2<-matrix(0,n,d)
n2<-0
for (i in 1:n){
    j<-1
    notjet<-TRUE
    while ((j<=rnum) && (notjet)){
         inside<-TRUE
         coordi<-1
         while ((inside) && (coordi<=d)){
             ala<-pcf$down[j,coordi]
             yla<-pcf$high[j,coordi]
             ala<-pcf$support[2*coordi-1]+ala*step[coordi]
             yla<-pcf$support[2*coordi-1]+yla*step[coordi]
             if ((dendat[i,coordi]<ala) || (dendat[i,coordi]>yla)) 
                         inside<-FALSE
             coordi<-coordi+1
         }
         if (inside){
              notjet<-FALSE
              if (varauslista[j]==0){ 
                  varauslista[j]<-1
                  n2<-n2+1
                  dendat2[n2,]<-dendat[i,]
                  den2pcf[n2]<-j
                  pcf2den[j]<-n2
              }
         }
         j<-j+1
    }
}
dendat2<-dendat2[1:n2,]

# make tree
parent<-matrix(0,n2,1)
center<-matrix(0,d,n2)
level<-matrix(0,n2,1)
for (i in 1:n2){
   rec<-den2pcf[i]
   node<-nodefinder[rec]
   level[i]<-lst$level[node]

   obs<-0
   curnode<-node
   notfound<-TRUE
   while ((notfound) && (lst$parent[curnode]>0)){
         curnode<-lst$parent[curnode] 
         rec<-lst$infopointer[curnode]
         if (pcf2den[rec]>0){ 
              notfound<-FALSE
              obs<-pcf2den[rec]
         }
   }
   parent[i]<-obs
}
center<-t(dendat2)

return(list(parent=parent,center=center,level=level,
dendat=dendat2,infopoint=seq(1:n2)))
}

listchange<-function(AtomlistAtom,AtomlistNext,totbegSepary,
begsSepaNext,begsSepaBegs,atomsSepaNext,atomsSepaAtom,
terminalnum,beg){
#
#create begs: beginnings of lists of atoms
#beg is index to AtomlistAtom/Next
#totbegsepary is index to begsSepaBegs/Next
#
begs<-matrix(0,terminalnum,1)
#
runnerBegs<-totbegSepary  #total beginning of list is at the root of the tree
runnerOrigi<-beg
runnerOrigiprev<-beg
sepalkm<-0
while (runnerBegs>0){
   sepalkm<-sepalkm+1
   runnerAtoms<-begsSepaBegs[runnerBegs]
   begs[sepalkm]<-runnerOrigi
   #  first step (in order to get also runnerOrigiprev to play)
   AtomlistAtom[runnerOrigi]<-atomsSepaAtom[runnerAtoms]
   runnerOrigiprev<-runnerOrigi
   runnerOrigi<-AtomlistNext[runnerOrigi]
   runnerAtoms<-atomsSepaNext[runnerAtoms]
   while (runnerAtoms>0){
       AtomlistAtom[runnerOrigi]<-atomsSepaAtom[runnerAtoms]
       runnerOrigiprev<-runnerOrigi
       runnerOrigi<-AtomlistNext[runnerOrigi]
       runnerAtoms<-atomsSepaNext[runnerAtoms]
   }
   AtomlistNext[runnerOrigiprev]<-0      #mark the end of the list
   runnerBegs<-begsSepaNext[runnerBegs]
}
#
begs<-begs[1:sepalkm]
#
return(list(begs=begs,AtomlistAtom=AtomlistAtom,AtomlistNext=AtomlistNext))
}
locofmax<-function(pcf)
{
d<-length(pcf$N)
step<-matrix(0,d,1)
for (i in 1:d){
   step[i]<-(pcf$support[2*i]-pcf$support[2*i-1])/pcf$N[i]
}

nod<-which.max(pcf$value)

lowi<-matrix(0,d,1)
uppi<-matrix(0,d,1)
for (jj in 1:d){
    lowi[jj]<-pcf$support[2*jj-1]+step[jj]*(pcf$down[nod,jj])
    uppi[jj]<-pcf$support[2*jj-1]+step[jj]*pcf$high[nod,jj]
}
baryc<-lowi+(uppi-lowi)/2  

return(baryc)
}

lst2xy<-function(lst,type="radius",gnum=1000)
{
# gives the x and y vectors of a volume transform

if (type=="radius") pv<-plotvolu(lst,data=T,toplot=F)
else{
   lst2<-lst
   lst2$volume<-lst$proba
   pv<-plotvolu(lst2,data=T,toplot=F)
}

lenni<-length(pv$xcoor)/2
xs<-t(matrix(pv$xcoor,2,lenni))
ys<-matrix(0,lenni,1)
for (i in 1:lenni) ys[i]<-pv$ycoor[2*i]

or<-order(ys)
xs<-xs[or,]
ys<-ys[or]

xlow<-min(xs)
xhig<-max(xs)
xstep<-(xhig-xlow)/gnum
x<-seq(xlow,xhig,xstep)
y<-matrix(0,length(x),1)

x[1]<-xs[1,1]
x[length(x)]<-xs[1,2]
i<-2
while (i <= lenni){
  lowind<-round(length(x)*(xs[i,1]-xlow)/(xhig-xlow))
  higind<-round(length(x)*(xs[i,2]-xlow)/(xhig-xlow))
  y[higind:lowind]<-ys[i]
  i<-i+1
}

return(list(x=x,y=y))
}



lstseq.kern<-function(dendat,hseq,N,lstree=NULL,level=NULL,
Q=NULL,kernel="gauss",hw=NULL,algo="leafsfirst",support=NULL)
{
hnum<-length(hseq)
if ((hnum>1) && (hseq[1]<hseq[2])) hseq<-hseq[seq(hnum,1)]

if (algo=="leafsfirst"){

  for (i in 1:hnum){   
      h<-hseq[i]
      pcf<-pcf.kern(dendat,h,N,kernel=kernel,support=support)
      if (!is.null(lstree)) lf<-leafsfirst(pcf)
      if (!is.null(level)){ 
           lev<-level*max(pcf$value)  
           refe<-locofmax(pcf)
           st<-leafsfirst(pcf,lev=lev,refe=refe)
      }
      if (i==1){
           if (hnum==1){ 
               pcfseq<-pcf
               if (!is.null(lstree)) lstseq<-lf
               if (!is.null(level)) stseq<-st
           }
           else{
               pcfseq<-list(pcf)
               if (!is.null(lstree)) lstseq<-list(lf)
               if (!is.null(level)) stseq<-list(st)
           }
      }
      else{
          pcfseq<-c(pcfseq,list(pcf))
          if (!is.null(lstree)) lstseq<-c(lstseq,list(lf))
          if (!is.null(level)) stseq<-c(stseq,list(st))
      }
  }

}
else{  #algo=="decomdyna"
  lstseq<-profkern(dendat,hseq,N,Q,kernel=kernel,hw=hw)
}

if (is.null(lstree)) lstseq<-NULL
if (is.null(level)) stseq<-NULL
return(list(lstseq=lstseq,pcfseq=pcfseq,stseq=stseq,hseq=hseq,type="kernel"))
}

makehis<-function(regdat)
{
xlkm<-length(regdat$hila[,1])  #muuttujien lkm
valipit<-matrix(0,1,xlkm)
i<-1
while (i<=xlkm){
  if (regdat$hila[i,1]>1) 
    valipit[i]<-(regdat$hila[i,3]-regdat$hila[i,2])/(regdat$hila[i,1]-1)
  i<-i+1
}
lnum<-length(regdat$ind[,1])   #length(regdat$dep)
items<-matrix(0,lnum,2*xlkm)
arvot<-matrix(0,lnum,1)
i<-1
while (i<=lnum){
  arvot[i]<-regdat$dep[i]  
  j<-1
  while (j<=xlkm){
    items[i,2*j-1]<-regdat$ind[i,j]-valipit[j]/2
    items[i,2*j]<-regdat$ind[i,j]+valipit[j]/2
    j<-j+1
  }
  i<-i+1
}
return(list(values=arvot,recs=items))
}


makeinfo<-function(left,right,mean,low,upp)
{
lehdet<-findleafs(left,right)

d<-dim(low)[2]
nodenum<-length(lehdet)         #length(left)

value<-matrix(0,nodenum,1)
infolow<-matrix(0,nodenum,d)
infoupp<-matrix(0,nodenum,d)
nodefinder<-matrix(0,nodenum,1)
infopointer<-matrix(0,nodenum,1)

runner<-1
leafnum<-0
while (runner<=nodenum){
  if ((!is.na(lehdet[runner])) && (lehdet[runner]==1) && (mean[runner]>0)){  
      # we are in leaf where the value is positive
      leafnum<-leafnum+1
      value[leafnum]<-mean[runner]
      nodefinder[leafnum]<-runner
      infolow[leafnum,]<-low[runner,]
      infoupp[leafnum,]<-upp[runner,]

      infopointer[runner]<-leafnum
  }
  runner<-runner+1
}
value<-value[1:leafnum]
nodefinder<-nodefinder[1:leafnum]
infolow<-infolow[1:leafnum,]
infoupp<-infoupp[1:leafnum,]

return(list(value=value,low=infolow,upp=infoupp,nodefinder=nodefinder,
infopointer=infopointer,
terminalnum=leafnum))
}
makeparent<-function(left,right)
{
parent<-matrix(0,length(left),1)

pino<-matrix(0,length(left),1)
pinin<-1
pino[1]<-1

while (pinin>0){

    node<-pino[pinin]
    pinin<-pinin-1

    if (left[node]>0){
       parent[left[node]]<-node
       parent[right[node]]<-node

       pinin<-pinin+1
       pino[pinin]<-right[node]
    }

    while (left[node]>0){
       
        node<-left[node]

        if (left[node]>0){
           parent[left[node]]<-node
           parent[right[node]]<-node

           pinin<-pinin+1
           pino[pinin]<-right[node]
        }
    }

}

return(t(parent))
}
massat<-function(rec){
#Calculates a vector of masses of a set of rectangles
#
#rec is k*(2*d)-matrix, represents k rectangles in d-space
#Returns a k-vector
#
#if (dim(t(rec))[1]==1) k<-1 else k<-length(rec[,1])  #rows of rec
if (dim(t(rec))[1]==1){
 d<-length(rec)/2
 vol<-1
 j<-1
   while ((j<=d) && (vol>0)){
     if (rec[2*j]<=rec[2*j-1]) vol<-0
     else vol<-vol*(rec[2*j]-rec[2*j-1])
     j<-j+1
   }
  tulos<-vol
}
else{
 k<-length(rec[,1])
 d<-length(rec[1,])/2
 tulos<-matrix(0,k,1)
 for (i in 1:k){
   vol<-1
   j<-1
   while ((j<=d) && (vol>0)){
     if (rec[i,2*j]<=rec[i,2*j-1]) vol<-0
     else vol<-vol*(rec[i,2*j]-rec[i,2*j-1])
     j<-j+1
   }
   tulos[i]<-vol
 }
}
return(tulos)
}

massone<-function(rec){
#Calculates the mass of a rectangle.
#
#rec is (2*d)-vector, represents rectangle in d-space
#Returns a real number >0.
#
d<-length(rec)/2
vol<-1
for (j in 1:d){
  vol<-vol*(rec[2*j]-rec[2*j-1])
}
return(vol) 
}

maxnodenum<-function(dendat,h,N,n,d)
{
minim<-matrix(0,d,1)
maxim<-matrix(0,d,1)
i<-1
while (i<=d){
  minim[i]<-min(dendat[,i])  
  maxim[i]<-max(dendat[,i])
  i<-i+1;
}
hmax<-max(h)
delta<-(maxim-minim+2*hmax)/(N+1)
mindelta<-min(delta)
maxpositive<-ceiling(n*(2*hmax/mindelta)^d)
bigd<-sum(log(N,base=2))
maxnode<-ceiling(bigd*maxpositive)

return(list(maxnode=maxnode,maxpositive=maxpositive));
}
modecent<-function(lst){
#
parents<-lst$parent
levels<-lst$level
volumes<-lst$volume   
centers<-lst$center
d<-dim(centers)[1]            #d<-length(centers[,1])
#
mlkm<-moodilkm(parents)
modloc<-mlkm$modloc
lkm<-mlkm$lkm
#
mut<-multitree(parents)
roots<-mut$roots
child<-mut$child
sibling<-mut$sibling 
#
crit<-rep(0,d)               #order so that 1st closest to origo
sibord<-siborder(mut,crit,centers)   
#
itemnum<-length(parents)
vecs<-matrix(NA,itemnum,4)
vecs<-alloroot(vecs,roots,sibord,levels,volumes)
vecs<-plotdata(roots,child,sibling,sibord,levels,volumes,vecs) 
#
res<-matrix(0,lkm,d)
#
for (i in 1:lkm){
   sija<-modloc[i]
   res[i,]<-centers[,sija]
}
#
ord<-vecs[,1]   #in this order we want modes
ordpick<-matrix(0,lkm,1)
for (i in 1:lkm){
  sija<-modloc[i]
  ordpick[i]<-ord[sija]
}
#
pointer<-seq(1:lkm)
pointer<-omaord2(pointer,ordpick) #pointer on the order determined by ord
#
endres<-res
for (i in 1:lkm){
  sija<-pointer[i]
  endres[i,]<-res[sija,]
}
#
return(endres)
}

modegraph<-function(estiseq,hseq=NULL,paletti=NULL)  #,reverse=F)
{
# we want that the largest h is first (1 mode, oversmoothing)

if (is.null(hseq))
   if (!is.null(estiseq$type)){
       if (estiseq$type=="greedy") hseq<--estiseq$hseq
       if (estiseq$type=="bagghisto") hseq<--estiseq$hseq
       if (estiseq$type=="carthisto")  hseq<--estiseq$leaf
       if (estiseq$type=="kernel")  hseq<-estiseq$hseq    
   }
   else hseq<-estiseq$hseq

hnum<-length(hseq)

treelist<-estiseq$lstseq
d<-dim(treelist[[1]]$center)[1]

if (hseq[1]<hseq[2]){   #(reverse){  
    #if ((hnum>1) && (is.null(hseq))) 
    hseq<-hseq[seq(hnum,1)]
    apuseq<-list(treelist[[hnum]])
    i<-2
    while (i <= hnum){
         apuseq<-c(apuseq,list(treelist[[hnum-i+1]]))
         i<-i+1 
   }
   treelist<-apuseq
}

if (is.null(paletti))
paletti<-c("red","blue","green","turquoise","orange","navy",
"darkgreen","orchid",colors()[50:100])

low<-matrix(0,hnum,1)
upp<-matrix(0,hnum,1)
tot<-moodilkm(treelist[[1]]$parent)$lkm   #tot is the number of modes over all lst:s
low[1]<-1
upp[1]<-tot
i<-2
while (i <= hnum){
  lkmm<-moodilkm(treelist[[i]]$parent)$lkm
  tot<-tot+lkmm
  low[i]<-upp[i-1]+1
  upp[i]<-low[i]+lkmm-1
  i<-i+1
}

xcoor<-matrix(0,tot,d)
ycoor<-matrix(0,tot,1)
parent<-matrix(0,tot,1)
mlabel<-matrix(0,tot,1)
flucpoints<-matrix(0,hnum,1)
nodepointer<-matrix(0,tot,1)
colot<-matrix("",tot,1)

# first we allocate colors for the largest h
colrun<-1  #low[1]
while (colrun<=upp[1]){
   colot[colrun]<-paletti[colrun]
   colrun<-colrun+1
}

laskuri<-1
srun<-1
mlkmpre<-1
flucnum<-0
while (srun<=hnum){  
    mlkm<-moodilkm(treelist[[srun]]$parent)
    if (mlkmpre < mlkm$lkm){
          flucnum<-flucnum+1
          flucpoints[flucnum]<-srun
    }

    for (j in 1:mlkm$lkm){
        loca<-mlkm$modloc[j]
        if (d>1){
           for (dim in 1:d){
              xcoor[laskuri,dim]<-treelist[[srun]]$center[dim,loca]
           }
        }
        else{
              xcoor[laskuri]<-treelist[[srun]]$center[loca]
        }
        ycoor[laskuri]<-hseq[srun]
        mlabel[laskuri]<-j
        nodepointer[laskuri]<-loca

        laskuri<-laskuri+1
    }

    if (srun>1){

       vec1<-matrix(0,mlkmpre,d)
       vec2<-matrix(0,mlkm$lkm,d)
       vec1[1:mlkmpre,]<-xcoor[low[srun-1]:upp[srun-1],]
       vec2[1:mlkm$lkm,]<-xcoor[low[srun]:upp[srun],]
       vm<-vectomatch(vec1,vec2)
       for (jj in low[srun]:upp[srun]){
           parent[jj]<-vm$parent[jj-low[srun]+1]+low[srun-1]-1
           if (vm$newnode[jj-low[srun]+1]==1){ 
                colot[jj]<-paletti[colrun]
                colrun<-colrun+1
           }
           else colot[jj]<-colot[parent[jj]]
      }
    }

    mlkmpre<-mlkm$lkm
    srun<-srun+1 
}

xcoor<-xcoor[1:(laskuri-1),]
ycoor<-ycoor[1:(laskuri-1)]
parent<-parent[1:(laskuri-1)]
colot<-colot[1:(laskuri-1)]
mlabel<-mlabel[1:(laskuri-1)]
nodepointer<-nodepointer[1:(laskuri-1)]
flucpoints<-flucpoints[1:flucnum]

mt<-list(xcoor=xcoor,ycoor=t(ycoor),
parent=parent,colot=colot,hseq=hseq,type=estiseq$type,
upp=upp,low=low,
mlabel=t(mlabel),
flucpoints=t(flucpoints),
nodepointer=t(nodepointer)
)

return(mt)
}




modetestgauss<-function(lst,n)
{

len<-length(lst$parent)
testvec<-matrix(0,len,1)    #this is output

em<-excmas(lst)

for (i in 1:len){

   if (lst$parent[i]!=0) val<-lst$level[lst$parent[i]]
   else val<-0

   a<-sqrt(n)*em[i]/sqrt(val*lst$volume[i])
   testvec[i]<-2*(1-pnorm(a))
}

return(testvec)
}
modetest<-function(pk,pknum,
h=NULL,N=NULL,Q=NULL,bootnum=NULL,delta=NULL,nsimu=NULL,minim=NULL,
type="boots",kernel="gauss",
n=NULL)
{

#pk is a list of level set trees
#h is vector of smoothing parameter values
#M is the number of bootstrap samples to be generated

run<-1
while (run<=pknum){
   curlst<-pk[[run]]

   if (type=="boots"){
       curh<-h[run]
       curmotes<-modetestydin(curlst,curh,N,Q,bootnum,delta,nsimu,minim,kernel)
   }
   else{
       curmotes<-modetestgauss(curlst,n)
   }

   if (run==1){
      if (pknum==1){
          moteslist<-curmotes
      }
      else{
          moteslist=list(curmotes)
      }
   }
   else{
      moteslist=c(moteslist,list(curmotes))
   }
   run<-run+1
}
#
return(moteslist)
}



modetestydin<-function(lstree,h,N,Q,bootnum,delta,nsimu,minim,kernel){

#we will approximate the estimate with a function whose values are
#levels of level set tree, this estimate has already been 
#normalized to integrate to one

index<-lstree$index
etnum<-dim(index)[1]
d<-length(N)

len<-length(lstree$parent)
mut<-multitree(lstree$parent)
mt<-pruneprof(mut)

#branchnodes<-findbranchMT(mt,len)
branchn<-findbranch(lstree$parent)$indicator
bnumbeg<-length(branchn)
branchnodes<-matrix(0,bnumbeg,1)
bnum<-0
for (i in 1:bnumbeg){
  if (branchn[i]==1){
      bnum<-bnum+1
      branchnodes[bnum]<-i
  }
}
branchnodes<-branchnodes[1:bnum]

testvec<-matrix(0,len,1)    #this is output

i<-1
while (i<=bnum){
   brnode<-branchnodes[i]
   
   #first cut the level set tree
   #3 cases: 1. brnode is linked from parent
   #         2. brnode is linked from previous sibling

   newchild<-mut$child
   newsibling<-mut$sibling
   newroots<-mut$roots

   brpare<-lstree$parent[brnode]
  
   if (brpare>0){  # brnode is not a root
 
   etsi<-mut$child[brpare]
{  if (etsi==brnode){
       newchild[brpare]<-mut$sibling[etsi]
   }
   else{
      while (etsi!=brnode){
         prevetsi<-etsi
         etsi<-mut$sibling[etsi]
      }
      newsibling[prevetsi]<-mut$sibling[etsi]
   }
} 
  
   #normalize the estimate to integrate to one
   
   kerroin<-cintemul(newroots,newchild,newsibling,lstree$volume,lstree$level)
   newlevel<-lstree$level/kerroin
   
   #creat value-vector "newvalue" with cutted values
   #newvalue*volofatom is probablility vector
   
   newvalue<-cutvalue(newroots,newchild,newsibling,
             newlevel,lstree$component,
             lstree$AtomlistAtom,lstree$AtomlistNext,etnum)
   
   #calculate the test statistics

         tstat<-excmas(lstree)[brnode]
          # cuttedlevel<-lstree$level[brpare]
          #cintemul(brnode,mut$child,mut$sibling,
          #lstree$volume,lstree$level-cuttedlevel)
   
   #generate samples from the cutted estimate
   
   overfrekv<-0
   j<-1
   while (j<=bootnum){
      dendatj<-simukern(nsimu,d,seed=j,newvalue,index,delta,minim,h)
      pk<-profkern(dendatj,h,N,Q,compoinfo=T,kernel=kernel)

      #find modes which are in the set associated with node brnode

      mlkm<-moodilkm(pk$parent)
      setissa<-matrix(0,mlkm$lkm,1)
      setissalkm<-0
      for (mrun in 1:mlkm$lkm){
           mloc<-mlkm$modloc[mrun]
           kandi<-pk$center[,mloc]
           torf<-onsetissa(kandi,h,delta,minim,
                           brnode,lstree$component,
                           lstree$index,
                           lstree$AtomlistAtom,lstree$AtomlistNext)
           if (torf){
               setissalkm<-setissalkm+1
               setissa[setissalkm]<-mloc 
           }
      }
      if (setissalkm>0){ 
        
         setissa<-setissa[1:setissalkm]

      #calculate the excess mass over "cuttedlevel" for
      #the modes in setissa 
      #Note that there may be a branching after "cuttedlevel"
      #We find the multitree for pk, then we cut this tree
      #by choosing the root node to be those nodes which are
      #arrived from modes (stop when the cuttedlevel is passed)
      
      cuttedlevel<-lstree$level[brpare]
      pkmut<-multitree(pk$parent)
      pkroots<-matrix(0,setissalkm,1)
      pkrootslkm<-0
      for (mrun in 1:setissalkm){
         node<-setissa[mrun]
         while ((pk$level[node]>cuttedlevel) && (node>0)){
              node<-pk$parent[node]
         }
         if (node>0){
             pkrootslkm<-pkrootslkm+1
             pkroots[pkrootslkm]<-node
         }
      }
      if (pkrootslkm>0){
         pkroots<-pkroots[1:pkrootslkm]

         bootstat<-cintemul(pkroots,pkmut$child,pkmut$sibling,
                            pk$volume,pk$level-cuttedlevel)
      }
      else{    #setissalkm>0, pkrootslkm==0
         bootstat<-0
      }
      
      }
      else{    #setissalkm==0
          bootstat<-0
      }

      if (bootstat<tstat){
          overfrekv<-overfrekv+1
      }
      j<-j+1
   }
   testvec[brnode]<-overfrekv/bootnum    #p-values are returned

   }

   i<-i+1
}

return(testvec)
}













moodilkm<-function(vanhat)
{
#Lasketaan moodien lukumaara tiheyspuusta.
#Tiheyspuusta kaytettavissa vektori vanhat.
#Mikali solmu ei ole minkaan solmun vanhempi, se on lehti.

pit<-length(vanhat)
leima<-matrix(0,pit,1)
i<-1
while (i<=pit){
  solmu<-vanhat[i]
  leima[solmu]<-1
  i<-i+1
}
eimoodi<-sum(leima)
lkm<-(pit-eimoodi)
ykk<-rep(1,pit)
modnodes<-ykk-leima
#
moodiloc<-matrix(0,lkm,1)
ind<-1
for (i in 1:pit){
  if (modnodes[i]==1){
       moodiloc[ind]<-i
       ind<-ind+1
  }
}
#
return(list(lkm=lkm,modnodes=t(modnodes),modloc=t(moodiloc)))
}


mtest<-function(profile,n){
#
parents<-profile$parent
volumes<-profile$volume
levels<-profile$level
#
nodelkm<-length(parents)
lowmasses<-matrix(1,nodelkm,1)
for (i in 1:nodelkm){
   par<-parents[i]
   if (par==0){
      lowmasses[i]<-levels[i]*volumes[i]
   }
   else{
      lowmasses[i]<-levels[par]*volumes[i]
   }
}
testcrit<-sqrt(lowmasses/n)
#
return(t(testcrit))
#return(t(lowmasses))
}






multitree<-function(parents)
{
#Makes sibling-links and child-links

itemnum<-length(parents)
sibling<-matrix(0,itemnum,1)
child<-matrix(0,itemnum,1)
roots<-matrix(0,itemnum,1)
siborder<-matrix(0,itemnum,1)

rootnum<-0
for (i in itemnum:1){
  par<-parents[i]
  if (par==0){   #i is root (does not have parent)
     rootnum<-rootnum+1
     roots[rootnum]<-i
     siborder[i]<-rootnum
  } 
  else{          #i has parent
      if (child[par]==0){  #no childs so far
        child[par]<-i
        siborder[i]<-1
      }
      else{    #go to the end of sibling list
        chi<-child[par]
        sibsi<-1
        while(sibling[chi]>0){
           chi<-sibling[chi]
           sibsi<-sibsi+1
        }
        sibling[chi]<-i    #put to the sibling list
        siborder[i]<-sibsi+1
      }
  }
}
roots<-roots[1:rootnum]
return(list(child=child,sibling=sibling,roots=roots,siborder=siborder))
}
nn.likeset<-function(dendat,radmat,k,p=0.1,lambda=NULL)
{
n<-dim(dendat)[1]
d<-dim(dendat)[2]

volunitball<-volball(1,d)

radit<-radmat[,k]
evat<-k/(n*radit^d*volunitball)
if (is.null(lambda)){
  maksi<-max(evat,na.rm=TRUE)
  lambda<-p*maksi
}
grt<-(evat>=lambda)

#dendatsub<-dendat[grt,]

return(grt)
}

nn.radit<-function(dendat,maxk)
{
n<-dim(dendat)[1]
radmat<-matrix(0,n,maxk)

eta<-dist(dendat)
#i<j eta[n*(i-1) - i*(i-1)/2 + j-i]

for (i in 2:(n-1)){
   i1<-seq(1,i-1)
   j1<-i
   irow1<-eta[n*(i1-1) - i1*(i1-1)/2 + j1-i1]
   j2<-seq(i+1,n)
   irow2<-eta[n*(i-1) - i*(i-1)/2 + j2-i]
   irow<-c(irow1,irow2)
   or<-order(irow)
   radmat[i,]<-irow[or[1:maxk]]
}

i<-1
j<-seq(i+1,n)
irow<-eta[n*(i-1) - i*(i-1)/2 + j-i]
or<-order(irow)
radmat[i,]<-irow[or[1:maxk]]

i<-n
i1<-seq(1,n-1)
j<-i
irow<-eta[n*(i1-1) - i1*(i1-1)/2 + j-i1]
or<-order(irow)
radmat[i,]<-irow[or[1:maxk]]

return(radmat)
}


omaind<-function(v){
#v on vektori, palautetaan indeksi jossa vektorin pienin arvo 
#
lkm<-length(v)
i<-1
while ((i<lkm) && (is.na(v[i]))) i<-i+1
if ((i==lkm) && (is.na(v[lkm]))) y<-1
 else
 if ((i==lkm) && (!is.na(v[lkm]))) y<-lkm
  else{
  apuu<-i
  valapu<-v[apuu]
  while (i<lkm){
    i<-i+1
    if ((!is.na(v[i])) && (v[i] < valapu)){
      apuu<-i
      valapu<-v[i]
    }
  }
y<-apuu
  }
return(y)
}
omamax<-function(v){
#v on vektori, palautetaan pienin arvo 
#
lkm<-length(v)
i<-1
while ((i<lkm) && (is.na(v[i]))) i<-i+1
if ((i==lkm) && (is.na(v[lkm]))) y<-NA
 else
 if ((i==lkm) && (!is.na(v[lkm]))) y<-v[lkm]
  else{
  apuu<-i
  valapu<-v[apuu]
  while (i<lkm){
    i<-i+1
    if ((!is.na(v[i])) && (v[i] > valapu)){
      apuu<-i
      valapu<-v[i]
    }
  }
y<-v[apuu]
  }
return(y)
}
omamin<-function(v){
#v on vektori, palautetaan pienin arvo 
#
lkm<-length(v)
i<-1
while ((i<lkm) && (is.na(v[i]))) i<-i+1
if ((i==lkm) && (is.na(v[lkm]))) y<-NA
 else
 if ((i==lkm) && (!is.na(v[lkm]))) y<-v[lkm]
  else{
  apuu<-i
  valapu<-v[apuu]
  while (i<lkm){
    i<-i+1
    if ((!is.na(v[i])) && (v[i] < valapu)){
      apuu<-i
      valapu<-v[i]
    }
  }
y<-v[apuu]
  }
return(y)
}
omaord2<-function(a,b){
#Jarjestaa vektorin a vektorin b mukaiseen jarjestykseen
#
#a and b are lnum-vectors
#
lnum<-length(a)  
orda<-a               #tahan oikea jarjestys
ordb<-b
i<-1 
while (i<=lnum){
   pienin<-omaind(b)
   ordb[i]<-b[pienin]
   orda[i]<-a[pienin]
   b[pienin]<-NA         #NA on plus aareton
   i<-i+1
}
return(orda)
}





omaord<-function(values,recs,frekv=NULL){
#Jarjestaa paloittain vakion funktion palat funktion arvojen
#mukaan suuruusjarjestykseen
#
#palvak on lnum*(1+2*xlkm)-matriisi, missa lnum on laatikkojen lkm,
#matriisin ensimmainen sarake sisaltaa estimaatin values laatikoittain,
#naitten mukaan matriisin rivit jarjestetaan.
#Muut sarakkeet sis laatikoitten maaritykset, ts jokaista
#muuttujaa kohden vaihteluvali 
#ep on toleranssiparametri yhtasuuruuden testauksessa
#
#kutsuu: omaind
#
lnum<-length(values)        #length(recs[,1])     #laatikoitten lkm
ordrecs<-recs               #tahan oikea jarjestys
ordvalues<-values
if (is.null(frekv)){
 ordfrekv<-NULL
 i<-1
 while (i<=lnum){
   pienin<-omaind(values)
   ordrecs[i,]<-recs[pienin,]
   ordvalues[i]<-values[pienin]
   values[pienin]<-NA       #NA on plus aareton
   i<-i+1
 }
}
else{
ordfrekv<-frekv
i<-1
 while (i<=lnum){
   pienin<-omaind(values)
   ordrecs[i,]<-recs[pienin,]
   ordvalues[i]<-values[pienin]
   ordfrekv[i]<-frekv[pienin]
   values[pienin]<-NA       #NA on plus aareton
   i<-i+1
 }
}
return(list(values=ordvalues,recs=ordrecs,frekv=ordfrekv))
}





onko<-function(rivi,j){
#Checks whether j is in rivi
#
#rivi is vector where beginning is positive integers, rest NA
#j is positive inetger
#
#Returns TRUE is j is in rivi, FALSE otherwise
#
len<-length(rivi)
res<-FALSE
i<-1
while ((!is.na(rivi[i])) && (i<=len) && (rivi[i]<=j)){
  if (rivi[i]==j) res<-TRUE
  i<-i+1
}
return(res)
}

onsetissa<-function(kandi,h,delta,minim,
brnode,component,
index,
AtomlistAtom,AtomlistNext){
#
itis<-F
d<-length(minim)
# 
node<-brnode
compo<-component[node]
ato<-compo                          #ato is pointer to "value"
while ((ato>0) && !(itis)){
    inde<-index[AtomlistAtom[ato]]
    keski<-minim-h+delta*inde
    for (din in 1:d){
      if ((kandi[din]>=(keski[din]-delta[din]/2)) &&   
          (kandi[din]<=(keski[din]+delta[din]/2))){
               itis<-T
      }
    }
    ato<-AtomlistNext[ato]
}
#
return(itis)
}
paraclus<-function(dendat,algo="kmeans",k=2,method="complete",
scatter=FALSE,coordi1=1,coordi2=2,levelmethod="center",
startind=c(1:k),range="global",terminal=TRUE,coordi=1,
paletti=NULL,xaxt="s",yaxt="s",cex.axis=1,pch.paletti=NULL)
{
if (is.null(paletti)) paletti<-seq(1,2000)
if (is.null(pch.paletti)) pch.paletti<-rep(21,2000)
if (algo!="kmeans"){ 
      method<-algo
      algo<-"hclust"
}

n<-dim(dendat)[1]
d<-dim(dendat)[2]
colot<-c(colors()[2],colors()[3])

if (algo=="kmeans"){
    starters<-dendat[startind,]
    cl<-kmeans(dendat,k,centers=starters)
    ct<-cl$cluster
    centers<-cl$centers
}
else if (algo=="hclust"){
       dis<-dist(dendat)
       hc <- hclust(dis, method=method)
       ct<-cutree(hc,k=k)
       centers<-matrix(0,k,d)
       for (ij in 1:k) centers[ij,]<-mean(data.frame(dendat[(ct==ij),]))
}

# calculate innerlevel
innerlevel<-matrix(0,n,1)
maxlevel<-matrix(0,k,1)
for (i in 1:n){
  classlabel<-ct[i]
  cente<-centers[classlabel,]
  if (levelmethod=="random"){ 
        set.seed(i)
        luku<-runif(1)
  }
  else{ 
        luku<-sqrt(sum((dendat[i,]-cente)^2))
  }
  innerlevel[i]<-luku  
  maxlevel[classlabel]<-max(maxlevel[classlabel],luku)
}
# calculate classlevel
classlevel<-matrix(0,k,1)
i<-2
while (i<=k){
   if (levelmethod=="random"){ 
        classlevel[i]<-classlevel[i-1]+1
   }
   else{
        classlevel[i]<-classlevel[i-1]+maxlevel[i-1]
   }
   i<-i+1
}
# calculate level
level<-matrix(0,n,1)
for (i in 1:n){
    classlabel<-ct[i]
    level[i]<-innerlevel[i]+classlevel[classlabel]
}

if (d<=5){ 
   lkm<-d  
   times<-0
   reminder<-d
} 
else{
   lkm<-5
   times<-floor(d/lkm)
   reminder<-d-lkm*times
}
curcolo<-1
ymin<-0  #min(level)
ymax<-max(level)

if (!terminal){
       coordinate<-coordi
       x<-dendat[,coordinate]
       if (range=="global"){
          xmin<-min(dendat) 
          xmax<-max(dendat)
       }
       else{
          xmin<-min(x)
          xmax<-max(x)
       }
       plot(x="",y="",xlab="",ylab="",xlim=c(xmin,xmax),ylim=c(ymin,ymax),
            xaxt=xaxt,yaxt=yaxt,cex.axis=cex.axis)
       for (j in 1:k){
         if (curcolo==1) curcolo<-2 else curcolo<-1
         polygon(c(xmin,xmax,xmax,xmin),
                 c(classlevel[j],classlevel[j],
                   classlevel[j]+maxlevel[j],classlevel[j]+maxlevel[j]),
                 col=colot[curcolo]) 
       }
       points(x,level,col=paletti[ct],pch=pch.paletti[ct])
       if (scatter) plot(dendat[,coordi1],dendat[,coordi2], col = paletti[ct],
                         xaxt=xaxt,yaxt=yaxt,pch=pch.paletti[ct])

}
########################################################
else{

t<-1
while (t<=times){
   mat<-matrix(c(1:lkm),1,lkm)
   x11()
   layout(mat)
   for (i in 1:lkm){
       coordinate<-(times-1)*lkm+i
       x<-dendat[,coordinate]
       if (range=="global"){
          xmin<-min(dendat) 
          xmax<-max(dendat)
       }
       else{
          xmin<-min(x)
          xmax<-max(x)
       }
       plot(x="",y="",xlab="",ylab="",xlim=c(xmin,xmax),ylim=c(ymin,ymax),
            xaxt=xaxt,yaxt=yaxt,cex.axis=cex.axis)
       for (j in 1:k){
         if (curcolo==1) curcolo<-2 else curcolo<-1
         polygon(c(xmin,xmax,xmax,xmin),
                 c(classlevel[j],classlevel[j],
                   classlevel[j]+maxlevel[j],classlevel[j]+maxlevel[j]),
                 col=colot[curcolo]) 
       }
       points(x,level,col=ct)
   }
   t<-t+1
}
if (reminder>0){
   lkm<-reminder
   mat<-matrix(c(1:lkm),1,lkm)
   x11()
   layout(mat)
   for (i in 1:lkm){
       coordinate<-i
       x<-dendat[,coordinate]
       if (range=="global"){
          xmin<-min(dendat) 
          xmax<-max(dendat)
       }
       else{
          xmin<-min(x)
          xmax<-max(x)
       }
       plot(x="",y="",xlab="",ylab="",xlim=c(xmin,xmax),ylim=c(ymin,ymax),
            xaxt=xaxt,yaxt=yaxt)
       for (j in 1:k){
         if (curcolo==1) curcolo<-2 else curcolo<-1
         polygon(c(xmin,xmax,xmax,xmin),
                 c(classlevel[j],classlevel[j],
                   classlevel[j]+maxlevel[j],classlevel[j]+maxlevel[j]),
                 col=colot[curcolo]) 
       }
       points(x,level,col=ct)
   }
}

# scatter plot
if (scatter){
   x11()
   plot(dendat[,coordi1],dendat[,coordi2], col = ct, xaxt=xaxt, yaxt=yaxt)
}

} # if terminal

}


paracoor<-function(dendat,xmargin=0.1,
paletti=matrix("black",dim(dendat)[1],1),noadd=TRUE,verti=NULL,cex.axis=1)
{
n<-dim(dendat)[1]
d<-dim(dendat)[2]
ylim<-c(min(dendat),max(dendat))

if (noadd)
plot(x="",y="",
xlim=c(1-xmargin,d+xmargin),ylim=ylim,
xlab="",ylab="",xaxt="n",cex.axis=cex.axis)

for (i in 1:n){
      points(dendat[i,],col=paletti[i])
      for (j in 1:(d-1)) segments(j,dendat[i,j],j+1,dendat[i,j+1],
      col=paletti[i])
}

if (!is.null(verti)) segments(verti,ylim[1],verti,ylim[2])

}

pcf.func<-function(func, N,
sig=rep(1,length(N)), support=NULL, theta=NULL, 
g=1, M=NULL, p=NULL, mul=3, t=NULL, 
marginal="normal", r=0,
mu=NULL, xi=NULL, Omega=NULL, alpha=NULL, df=NULL, 
a=0.5, b=0.5, distr=FALSE, std=1, lowest=0) # contrast="loglik")   
{
# t<-rep(1,length(N))

d<-length(N)

if (d>1){

  if (marginal=="unif") support<-c(0,sig[1],0,sig[2])

  recnum<-prod(N)
  value<-matrix(0,recnum,1)
  index<-matrix(0,recnum,d)

  # new ############################################

  if (func=="mixt"){ 

     if (is.null(support)){
       support<-matrix(0,2*d,1)
       for (i in 1:d){
           support[2*i-1]<-min(M[,i]-mul*sig[,i])
           support[2*i]<-max(M[,i]+mul*sig[,i])
       }
     }
     lowsuppo<-matrix(0,d,1)
     for (i in 1:d) lowsuppo[i]<-support[2*i-1]
     step<-matrix(0,d,1)
     for (i in 1:d) step[i]<-(support[2*i]-support[2*i-1])/N[i]
     mixnum<-length(p)

     numpositive<-0
     for (i in 1:recnum){
        inde<-digit(i-1,N)+1
        point<-lowsuppo+step*inde-step/2
 
        if (!is.null(theta)){
           rotmat<-matrix(c(cos(theta),-sin(theta),sin(theta),cos(theta)),2,2)
           point<-rotmat%*%point
        }

        valli<-0
        for (mi in 1:mixnum){
            evapoint<-(point-M[mi,])/sig[mi,]
            valli<-valli+p[mi]*evanor(evapoint)/prod(sig[mi,])
        }
        if (valli>lowest){
           numpositive<-numpositive+1
           value[numpositive]<-valli
           index[numpositive,]<-inde
        }
     }
     value<-value[1:numpositive]
     index<-index[1:numpositive,]
     down<-index-1
     high<-index
  }


  else if (func=="student"){ 
     lowsuppo<-matrix(0,d,1)
     for (i in 1:d) lowsuppo[i]<-support[2*i-1]
     step<-matrix(0,d,1)
     for (i in 1:d) step[i]<-(support[2*i]-support[2*i-1])/N[i]

     numpositive<-0
     for (i in 1:recnum){
        inde<-digit(i-1,N)+1
        x<-lowsuppo+step*inde-step/2

        #valli<-eva.student(x,t,marginal,sig,r,df)

        margx<-matrix(0,d,1)
        u<-matrix(0,d,1)

        if (marginal=="unif"){
           for (j in 1:d){
             u[j]<-x[j]/sig[j]  #+1/2
             margx[j]<-1/sig[j]
           }
        }
        if ((marginal=="normal")||(marginal=="gauss")){
           for (j in 1:d){
             u[j]<-pnorm(x[j]/sig[j])
             margx[j]<-evanor(x[j]/sig[j])/sig[j]
           }
        }
        if (marginal=="student"){
          for (j in 1:d){
             u[j]<-pt(x[j]/sig[j],df=t[j])
             margx[j]<-dt(x[j]/sig[j],df=t[j])/sig[j]
          }
        }
        
        x1<-qt(u[1],df=df)
        x2<-qt(u[2],df=df)

        d<-2
        vakio<-gamma((df+d)/2)*gamma(df/2)/gamma((df+1)/2)^2
        nelio<-(x1^2+x2^2-2*r*x1*x2)/(1-r^2)
        prod<-(1+x1^2/df)^((1+df)/2)*(1+x2^2/df)^((1+df)/2)
        copuval<-vakio*(1-r^2)^(-1/2)*prod*(1+nelio/df)^(-(df+d)/2)

        valli<-copuval*margx[1]*margx[2]

        ###############################################

        if (valli>0){
           numpositive<-numpositive+1
           value[numpositive]<-valli
           index[numpositive,]<-inde
        }
     }
     value<-value[1:numpositive]
     index<-index[1:numpositive,]
     down<-index-1
     high<-index
  }

  else if (func=="gauss"){ 
     lowsuppo<-matrix(0,d,1)
     for (i in 1:d) lowsuppo[i]<-support[2*i-1]
     step<-matrix(0,d,1)
     for (i in 1:d) step[i]<-(support[2*i]-support[2*i-1])/N[i]

     numpositive<-0
     for (i in 1:recnum){
        inde<-digit(i-1,N)+1
        x<-lowsuppo+step*inde-step/2

        #valli<-eva.copula(x,type="gauss",marginal=marginal,sig=sig,r=r,t=t)

        margx<-matrix(0,d,1)
        u<-matrix(0,d,1)

        if (marginal=="unif"){
           for (j in 1:d){
             u[j]<-x[j]/sig[j]  #+1/2
             margx[j]<-1/sig[j]
           }
        }
        if ((marginal=="normal")||(marginal=="gauss")){
           for (j in 1:d){
             u[j]<-pnorm(x[j]/sig[j])
             margx[j]<-evanor(x[j]/sig[j])/sig[j]
           }
        }
        if (marginal=="student"){
          for (j in 1:d){
             u[j]<-pt(x[j]/sig[j],df=t[j])
             margx[j]<-dt(x[j]/sig[j],df=t[j])/sig[j]
          }
        }
        
        x1<-qnorm(u[1],sd=1)
        x2<-qnorm(u[2],sd=1)

        nelio<-(x1^2+x2^2-2*r*x1*x2)/(1-r^2)
        copuval<-(1-r^2)^(-1/2)*exp(-nelio/2)/exp(-(x1^2+x2^2)/2)

        valli<-copuval*margx[1]*margx[2]

        ########################################

        if (valli>0){
           numpositive<-numpositive+1
           value[numpositive]<-valli
           index[numpositive,]<-inde
        }
     }
     value<-value[1:numpositive]
     index<-index[1:numpositive,]
     down<-index-1
     high<-index
  }


else{

# old #########################################################

if (is.null(support)){

   if (func=="epan"){
      if (is.null(sig)) sig<-c(1,1)
      support<-matrix(0,2*d,1)
      for (i in 1:d){
          support[2*i-1]<--sig[i]
          support[2*i]<-sig[i]
      }
   }

}

if ((marginal=="unif")) support<-c(0,sig[1],0,sig[2])
# && (is.null(support))) 
#support<-c(-sig[1]/2,sig[1]/2,-sig[2]/2,sig[2]/2)


lowsuppo<-matrix(0,d,1)
for (i in 1:d) lowsuppo[i]<-support[2*i-1]
step<-matrix(0,d,1)
for (i in 1:d) step[i]<-(support[2*i]-support[2*i-1])/N[i]

numpositive<-0
for (i in 1:recnum){
    inde<-digit(i-1,N)+1
    #if ((inde[1]==0) && (inde[2]==N[2])) inde<-c(0,0)
    point<-lowsuppo+step*inde-step/2

    if (!is.null(theta)){
         rotmat<-matrix(c(cos(theta),-sin(theta),sin(theta),cos(theta)),2,2)
         point<-rotmat%*%point
    }

    if (func=="prod") valli<-eva.prod(point,marginal,g)
    if (func=="skewgauss") valli<-eva.skewgauss(point,mu,sig,alpha)
    #if (func=="dmsn") valli<-dmsn(point,xi,Omega,alpha)
    if (func=="gumbel") valli<-eva.copula(point,
        type="gumbel",marginal=marginal,sig=sig,r=r,t=t,g=g)
    if (func=="frank") valli<-eva.copula(point,
        type="frank",marginal=marginal,sig=sig,t=t,g=g)
    if (func=="plackett") valli<-eva.plackett(point,t,marginal,sig)
    if (func=="clayton2") valli<-eva.clayton(point,t,marginal,sig,df)
    if (func=="clayton") valli<-eva.copula(point,
        type="clayton",marginal=marginal,sig=sig,r=r,t=t,g=g)
    if (func=="cop6") valli<-eva.cop6(point,t,marginal,sig)
    if (func=="epan") valli<-epan(point)
    if (func=="normal") 
        valli<-eva.gauss(point,t=t,marginal=marginal,sig=sig,r=r)   
    if (func=="hat") valli<-eva.hat(point,a=a,b=b)

    if (valli>0){
       numpositive<-numpositive+1
       value[numpositive]<-valli
       index[numpositive,]<-inde
    }
}

value<-value[1:numpositive]
index<-index[1:numpositive,]
down<-index-1
high<-index

}


pcf<-list(
value=value,index=index,
down=down,high=high,  #step=delta,
support=support,N=N)

  #pcf<-eval.func.dD(func,N,
  #sig=sig,support=support,theta=theta,g=g,
  #M=M,p=p,mul=mul,
  #t=t,marginal=marginal,r=r, 
  #mu=mu,xi=xi,Omega=Omega,alpha=alpha,df=df,a=a,b=b)

}

else{  # (d==1){ ######################################################

  pcf<-eval.func.1D(func,N,
  support=support,g=g,std=std,distr=distr,
  M=M,sig=sig,p=p,
  a=a,b=b,d=2)

}


return(pcf)

}

pcf.histo<-function(dendat,N,weights=rep(1,dim(dendat)[1]))
{
n<-dim(dendat)[1]
d<-dim(dendat)[2]
support<-matrix(0,2*d,1)
for (i in 1:d){
       support[2*i-1]<-min(dendat[,i])
       support[2*i]<-max(dendat[,i])
}

step<-matrix(0,d,1)
for (i in 1:d) step[i]<-(support[2*i]-support[2*i-1])/N[i]
recnum<-prod(N)
rowpointer<-matrix(0,recnum,1)

value<-matrix(0,recnum,1)
index<-matrix(0,recnum,d)

inde<-matrix(0,d,1)
numpositive<-0
for (i in 1:n){
    # find the right rectangle
    point<-dendat[i,]
    weight<-weights[i]
   for (k in 1:d) inde[k]<-min(floor((point[k]-support[2*k-1])/step[k]),N[k]-1)
    # inde[k] should be between 0 and N[k]-1

    # find the right row (if already there)
    recnum<-0
    for (kk in 1:d){
        if (kk==1) tulo<-1 else tulo<-prod(N[1:(kk-1)])
        recnum<-recnum+inde[kk]*tulo
    }
    recnum<-recnum+1
    row<-rowpointer[recnum]

    # update the value or create a new row
    if (row>0) value[row]<-value[row]+weight
    else{
         numpositive<-numpositive+1
         rowpointer[recnum]<-numpositive
         value[numpositive]<-weight
         index[numpositive,]<-inde
    }
}
value<-value[1:numpositive]
index<-index[1:numpositive,]
down<-index
high<-index+1

pcf<-list(
value=value,index=NULL,
down=down,high=high,  #step=delta,
support=support,N=N)
return(pcf)
}




pcf.kernC<-function(dendat,h,N,kernel="epane",hw=NULL)
# creates piecewise constant function object
{
keva<-kereva(dendat,h,N,kernel=kernel,hw=hw)

d<-length(N)
recnum<-dim(keva$index)[1]
down<-matrix(0,recnum,d)
high<-matrix(0,recnum,d)
for (i in 1:recnum){
     down[i,]<-keva$index[i,]-1
     high[i,]<-keva$index[i,]
}

return(list(value=keva$value,down=down,high=high,N=N,support=keva$suppo,
index=keva$index))
}


pcf.kern<-function(dendat,h,N,kernel="gauss",weights=NULL,support=NULL,
lowest=0)
{
d<-length(N)

if (d>1){

if (kernel=="bart") 
   ker<-function(xx,d){ 
         musd<-2*pi^(d/2)/gamma(d/2)
         c<-d*(d+2)/(2*musd)
         return( c*(1-rowSums(xx^2))*(rowSums(xx^2) <= 1) ) 
   }
if (kernel=="gauss") 
   ker<-function(xx,d){ return( (2*pi)^(-d/2)*exp(-rowSums(xx^2)/2) ) }
if (kernel=="uniform") 
   ker<-function(xx,d){ 
         c<-gamma(d/2+1)/pi^(d/2) 
         return( (rowSums(xx^2) <= 1) ) 
   } 
if (kernel=="epane") 
   ker<-function(xx,d){ 
      c<-(3/4)^d 
      xxx<-(1-xx^2)*(1-xx^2>=0)
      return( c*apply(xxx,1,prod) ) 
   } 

if (kernel=="gauss") radi<-2*h else radi<-h

recnum<-prod(N)
value<-matrix(0,recnum,1)
index<-matrix(0,recnum,d)

if (is.null(support)){
  support<-matrix(0,2*d,1)
  for (i in 1:d){
     support[2*i-1]<-min(dendat[,i])-radi
     support[2*i]<-max(dendat[,i])+radi
  }
}
lowsuppo<-matrix(0,d,1)
for (i in 1:d) lowsuppo[i]<-support[2*i-1]
step<-matrix(0,d,1)
for (i in 1:d) step[i]<-(support[2*i]-support[2*i-1])/N[i]

numpositive<-0
for (i in 1:recnum){
     inde<-digit(i-1,N)+1
     arg<-lowsuppo+step*inde-step/2
     argu<-matrix(arg,dim(dendat)[1],d,byrow=TRUE)
#     neigh<-(rowSums((argu-x)^2) <= radi^2)
#     if (sum(neigh)>=2){     # if there are obs in the neigborhood
#
#       xred<-dendat[neigh,]
#       argu<-matrix(arg,dim(xred)[1],d,byrow=TRUE)

       w<-ker((dendat-argu)/h,d)/h^d
       valli<-mean(w)
       if (!is.null(weights)) valli<-t(weights)%*%w
#     }
#     else valli<-mean(y)

      if (valli>lowest){
           numpositive<-numpositive+1
           value[numpositive]<-valli
           index[numpositive,]<-inde
      }
      #value[i]<-valli
      #index[i,]<-inde

}

value<-value[1:numpositive]
index<-index[1:numpositive,]
down<-index-1
high<-index

pcf<-list(
value=value,index=index,
down=down,high=high,  
support=support,N=N)

}
else{  # d==1  #########################################

d<-1
x<-matrix(dendat,length(dendat),1)

if (kernel=="gauss") ker<-function(xx,d){ return( (2*pi)^(-1/2)*exp(-xx^2/2) ) }
if (kernel=="uniform") ker<-function(xx,d){ return( (abs(xx) <= 1) ) }

index<-seq(1:N)
len<-length(index)

value<-matrix(0,N,1)
if (is.null(support)){
   support<-matrix(0,2,1)
   support[1]<-min(x)
   support[2]<-max(x)
}
step<-(support[2]-support[1])/N
lowsuppo<-support[1]

numpositive<-0
for (i in 1:N){
     inde<-i
     argu<-lowsuppo+step*inde-step/2
     w<-ker((x-argu)/h,1)/h
     if (!is.null(weights)) valli<-t(weights)%*%w else valli<-mean(w)
     if (valli>lowest){
           numpositive<-numpositive+1
           value[numpositive]<-valli
           index[numpositive]<-inde
     }
}

value<-value[1:numpositive]
index<-index[1:numpositive]

down<-matrix(0,numpositive,1)
high<-matrix(0,numpositive,1)
down[,1]<-index-1
high[,1]<-index

pcf<-list(
value=value,
down=down,high=high,
support=support,N=N)

}

return(pcf)
}
perspec.dyna<-function(x,y,z,col="black",phi=10,theta=0)
{
persp(x=x,y=y,z=z,col=col,
xlab="level",ylab="h",zlab="",ticktype="detailed",
phi=phi,theta=theta)

loc<-locator(1)
ycor<-loc$y 

alaraja<--0.4
while (loc$y>=alaraja){

     if (loc$x>=0) theta<-theta+10 else theta<-theta-10
     if (loc$y>=0) phi<-phi+10 else phi<-phi-10

     persp(x=x,y=y,z=z,col=col,
     xlab="level",ylab="h",zlab="",ticktype="detailed",
     phi=phi,theta=theta)

     loc<-locator(1)
}
dev.off()
}

pituus<-function(x){
#laskee euklid pituuden nelion matriisien x riveille
#
d<-length(x[1,])
lkm<-length(x[,1])
vast<-matrix(0,lkm,1)
i<-1
while (i<=lkm){
  j<-1
  while (j<=d){
    vast[i]<-vast[i]+(x[i,j])^2
    j<-j+1
  }
  i<-i+1
}
return(t(vast))
}
plotbary<-function(lst,coordi=1,
plot=TRUE,data=FALSE,crit=NULL,orderrule="distcenter",
modelabel=FALSE,ptext=0,leimat=NULL,symbo=NULL,
info=NULL,infolift=0,infopos=0,
xmarginleft=0,xmarginright=0,ymargin=0,
xlim=NULL,ylim=NULL,xaxt="s",yaxt="s",
nodesymbo=20,col=NULL,col.axis="black",collines=NULL,paletti=NULL,
shift=0,shiftindex=NULL,
modlabret=FALSE,modecolo=NULL,modepointer=NULL,colometh="lst",
colothre=min(lst$level),lines=TRUE,wedge=FALSE,lty.wedge=2,
title=TRUE,titletext="coordinate",
cex=NULL,nodemag=NULL,cex.sub=1,cex.axis=1,newtitle=FALSE,cex.lab=1
)
{

parent<-lst$parent
center<-lst$center
level<-lst$level

if (is.null(paletti))
 paletti<-c("red","blue","green",
 "orange","navy","darkgreen",
 "orchid","aquamarine","turquoise",
 "pink","violet","magenta","chocolate","cyan",
 colors()[50:657],colors()[50:657])
if (is.null(col)) 
   if (colometh=="lst")
            col<-colobary(parent,paletti,
                 modecolo=modecolo,modepointer=modepointer)
   else col<-colobary.roots(lst$parent,lst$level,paletti=paletti,
                            colothre=colothre)

if (is.null(collines)) collines<-col

nodenum<-length(parent)
xcoordinate<-center[coordi,]

if (is.null(xlim))
xlim<-c(min(xcoordinate)-xmarginleft,max(xcoordinate)+xmarginright)
ylim<-c(0,max(level)+ptext+ymargin)

if (newtitle) xlab<-paste(titletext,as.character(coordi))
else xlab<-""
plot(xcoordinate,level,xlab=xlab,ylab="",
xlim=xlim,ylim=ylim,xaxt=xaxt,yaxt=yaxt,
pch=nodesymbo,col=col,col.axis=col.axis,cex=nodemag,
cex.axis=cex.axis,cex.lab=cex.lab) 
if (title) title(sub=paste(titletext,as.character(coordi)),cex.sub=cex.sub)

if (lines){
   for (i in 1:nodenum){
       if (parent[i]>0){
           xchild<-xcoordinate[i]
           ychild<-level[i]
           xparent<-xcoordinate[parent[i]]
           yparent<-level[parent[i]]
           if (length(collines)>1) colli<-collines[i] else colli<-collines
           segments(xparent,yparent,xchild,ychild,col=colli) 
        }
   }
}

if (wedge){
  maxx<-max(xcoordinate)
  minx<-min(xcoordinate)
  righthigh<-maxx-lst$refe[coordi]
  lefthigh<-lst$refe[coordi]-minx
  segments(lst$refe[coordi],0,maxx,righthigh,lty=lty.wedge)
  segments(lst$refe[coordi],0,minx,lefthigh,lty=lty.wedge)
}

#########
#########
if (modlabret) modelabel<-TRUE
if (modelabel){

data<-plotprof(lst,plot=F,data=T,cutlev=NULL,ptext=NULL,info=NULL,
infolift=0,infopos=0,crit=crit,orderrule=orderrule)
vecs<-data$vecs
mlkm<-moodilkm(parent)
modloc<-mlkm$modloc 

nodenum<-length(vecs[,1])
xcoor<-matrix(0,2*nodenum,1)
ycoor<-matrix(0,2*nodenum,1)

for (i in 1:nodenum){
 xcoor[2*i-1]<-vecs[i,1]
 xcoor[2*i]<-vecs[i,3]
 ycoor[2*i-1]<-vecs[i,2]
 ycoor[2*i]<-vecs[i,4]
}                     
moodinum<-length(modloc)
modelocx<-matrix(0,moodinum,1)
modelocy<-matrix(0,moodinum,1)
if (is.null(leimat)){
   if (is.null(symbo)){
       labels<-paste("M",1:moodinum,sep="")
   }
   else{
         if (symbo=="empty") labels<-paste("",1:moodinum,sep="")
         else  labels<-paste(symbo,1:moodinum,sep="")
   }
}
else{
   labels<-leimat
}
xcor<-matrix(0,moodinum,1)
for (i in 1:moodinum){
    loc<-modloc[i]
    xcor[i]<-xcoor[2*loc-1]
}
modloc<-omaord2(modloc,xcor)
for (i in 1:moodinum){
    loc<-modloc[i]
    modelocx[i]<-xcoordinate[loc]
    modelocy[i]<-level[loc]+ptext
}
if (!is.null(shiftindex)) modelocx[shiftindex]<-modelocx[shiftindex]+shift
text(modelocx,modelocy,labels,cex=cex)         

if (modlabret){ 
   d<-dim(lst$center)[1]
   modelocat<-matrix(0,moodinum,d)
   for (i in 1:moodinum){
       loc<-modloc[i]
       modelocat[i,]<-lst$center[,loc]
   }   
   return(list(modelocat=modelocat,labels=labels))
}

}
############################################
}











plotbary.slide<-function(tt)
{
d<-dim(tt$center)[1]
coordi<-1
plotbary(tt,paletti=seq(1:1000),coordi=coordi)
loc<-locator(1)
while (loc$y>=0){
    if (coordi==d) coordi<-1 else coordi<-coordi+1         
    plotbary(tt,paletti=seq(1:1000),coordi=coordi)          
    loc<-locator(1)
}

}

plotbranchmap<-function(bm,phi=55,theta=30)
{

persp(x=bm$level,y=bm$h,z=bm$z, 
xlab="level",ylab="h",zlab="excess mass",
ticktype="detailed", border=NA, shade=0.75,
col=bm$col,phi=phi,theta=theta) 

}


plotdata<-function(roots,child,sibling,sibord,levels,volumes,vecs)
{
#plots level-set profile

#parents<-c(0,1,1,0,4,2)
#levels<-c(1,2,2,1,2,3)
#volumes<-c(4,2,1,2,1,1)

itemnum<-length(volumes)

#vecs<-matrix(NA,itemnum,4)
#vecs<-alloroot(vecs,roots,sibord,levels,volumes)

rootnum<-length(roots)
left<-child
right<-sibling

for (i in 1:rootnum){
    pino<-matrix(0,itemnum,1)
    pino[1]<-roots[i]  
    pinin<-1
    while (pinin>0){
        cur<-pino[pinin]      #take from stack
        pinin<-pinin-1
        if (left[cur]>0){     #if not leaf (root may be leaf)
           vecs<-allokoi(vecs,cur,child,sibling,sibord,levels,volumes)   
        }
        if (right[cur]>0){    #if right exists, put to stack
            pinin<-pinin+1
            pino[pinin]<-right[cur]
        }
        while (left[cur]>0){    #go to leaf and put right nodes to stack
             cur<-left[cur]
             if (left[cur]>0){  #if not leaf
                vecs<-allokoi(vecs,cur,child,sibling,sibord,levels,volumes)
             }
             if (right[cur]>0){ #if right exists, put to stack
                pinin<-pinin+1
                pino[pinin]<-right[cur]
             }
        }
    }
}       
#
return(vecs)
}







plotdelineator<-function(shtseq,coordi=1,ngrid=40,shift=0.05,
volumefunction=NULL,redu=TRUE,type="l")
{
if (is.null(volumefunction)){
   lnum<-length(shtseq$level)
   st<-shtseq$shtseq[[1]]
   td<-treedisc(st,shtseq$pcf,ngrid=ngrid)
   #td<-prunemodes(td,exmalim=0.5)$lst
   reduseq<-list(td)
   for (i in 2:lnum){
       st<-shtseq$shtseq[[i]]
       td<-treedisc(st,shtseq$pcf,ngrid=ngrid)
       #td<-prunemodes(td,exmalim=0.00001)$lst
       reduseq<-c(reduseq,list(td))
   }
   estiseq<-list(lstseq=reduseq,hseq=shtseq$level)
   mg<-modegraph(estiseq)
   plotmodet(mg,coordi=coordi,shift=shift)
}
else{
    vd<-volumefunction
    if (redu){
       x<-vd$delineator.redu[,coordi]
       y<-vd$delineatorlevel.redu
       or<-order(x)
       x1<-x[or]
       y1<-y[or]
       plot(x1,y1,type=type,
            ylab="level",xlab=paste("coordinate",as.character(coordi)))
    }
    else
       plot(vd$delineator[,coordi],vd$delineatorlevel,ylab="level")
}    

}


plotexmap<-function(sp,mt,
xaxt="n",
lift=0.1,leaflift=0.1,ylim=NULL,
leafcolors=NULL
)
{
if (is.null(leafcolors)) lc<-mt$colot
c2s<-colo2scem(sp,mt,lc)

plotvecs(sp$bigvecs,sp$bigdepths,
lift=lift,xaxt="n",
ylim=ylim,
#ylim=c(horilines[length(horilines)],horilines[1]),   #hseq[1]),
leafcolors=c2s,leaflift=leaflift)                        #log="y")

}

plotinfo<-function(vecs,info,pos=0,adj=NULL,lift=0,digits=3){
#
nodenum<-length(vecs[,1])
#
#remain<-data$remain
#if (!is.null(remain)){  #if we have cutted, cut also info
#   lenrem<-length(remain)
#   newinfo<-matrix(0,lenrem,1) 
#   for (i in 1:lenrem){
#      point<-remain[i]
#      newinfo[i]<-info[point]
#   }
#   info<-newinfo
##  orinodenum<-length(info)
##  newinfo<-matrix(0,orinodenum,1)
##  ind<-1
##  for (i in 1:orinodenum){
##     if (remain[i]==1){  
##        newinfo[ind]<-info[i]
##        ind<-ind+1
##     }
##  }
##  info<-newinfo[1:nodenum]
#}
##
infolocx<-matrix(nodenum,1)
infolocy<-matrix(nodenum,1)
#
for (i in 1:nodenum){
  infolocx[i]<-vecs[i,3]   #+(vecs[i,3]-vecs[i,1])/2  
  infolocy[i]<-vecs[i,2]+lift
}
info<-format(info,digits=digits)
text(infolocx,infolocy,info,pos,adj)
}


plot.kernscale<-function(scale,pnum=60,maxy0=0,dens=FALSE,cex.axis=1)
{
   hnum<-length(scale$hseq)
   for (i in 1:hnum){
     pk<-scale$pcfseq[[i]]
     dp<-draw.pcf(pk,dens=dens,pnum=pnum)
     if (i==1){ 
           minx<-min(dp$x) 
           miny<-min(dp$y)
           maxx<-max(dp$x) 
           maxy<-max(dp$y)  
     }
     else{ 
          minx<-min(minx,min(dp$x))
          miny<-min(miny,min(dp$y))
          maxx<-max(maxx,max(dp$x))
          maxy<-max(maxy,max(dp$y))
     }
   }
   maxy<-max(maxy,maxy0)
   plot(x="",y="",xlim=c(minx,maxx),ylim=c(miny,maxy),xlab="",ylab="",
   cex.axis=cex.axis)
   for (i in 1:hnum){
     pk<-scale$pcfseq[[i]]
     dp<-draw.pcf(pk,dens=dens,pnum=pnum)
     matpoints(dp$x,dp$y,type="l")
   }
}


plotmodet<-function(mt,coordi=1,colot=NULL,
shift=0,xlim=NULL,xlab="",ylab="",
horilines=NULL,
symbo=20,loga=NULL,lty="dashed",
cex.axis=1,title=TRUE,cex.sub=1,cex.lab=1,
xaxt="s",yaxt="s")
{
epsi<-0.0000001
if (!is.null(horilines)) horilines<-mt$hseq[horilines]

if (is.null(loga)) 
   if (!is.null(mt$type)){
       if (mt$type=="greedy") loga<-"not"
       if (mt$type=="bagghisto") loga<-"not"
       if (mt$type=="carthisto") loga<-"not"
       if (mt$type=="kernel") loga<-"y"
   }
   else loga<-"y"

d<-dim(mt$xcoor)[2]

if (is.null(colot)){
    as<-mt$colot
}
else if (colot=="black"){
   lenni<-length(mt$ycoor)
   as<-matrix("black",lenni,1)
}
else as<-colot

if (d==1) xvec<-mt$xcoor
else xvec<-mt$xcoor[,coordi]
yvec<-mt$ycoor
len<-length(xvec)
for (i in 1:len){
  j<-i+1
  while (j<=len){
    if ((xvec[i]<=xvec[j]+epsi)&&(xvec[i]>=xvec[j]-epsi)&& 
        (yvec[i]<=yvec[j]+epsi)&&(yvec[i]>=yvec[j]-epsi)){
        #&&(as[i]!=as[j])){
             #xvec[j]<-xvec[j]+shift
             xvec[i]<-xvec[i]+shift
    }    
    j<-j+1
  }
}
if (loga=="y")
plot(xvec,yvec,col=as,xlim=xlim,xlab=xlab,ylab=ylab,pch=symbo,log=loga,
     cex.axis=cex.axis,cex.lab=cex.lab,xaxt=xaxt,yaxt=yaxt)   
else
plot(xvec,yvec,col=as,xlim=xlim,xlab=xlab,ylab=ylab,pch=symbo,
     cex.axis=cex.axis,cex.lab=cex.lab,xaxt=xaxt,yaxt=yaxt) 

if (title) title(sub=paste("coordinate",as.character(coordi)),cex.sub=cex.sub)


if (!is.null(horilines)){
  xmin<-min(xvec)
  xmax<-max(xvec)
  horilen<-length(horilines)
  for (i in 1:horilen){
    segments(xmin,horilines[i],xmax,horilines[i],lty=lty)
  }
}

itemnum<-length(mt$parent)
for (i in 1:itemnum){
    if (mt$parent[i]>0){
        xchild<-mt$xcoor[i,coordi]
        #if (loga=="y") ychild<-mt$ycoor[i] else 
        ychild<-mt$ycoor[i]
        xparent<-mt$xcoor[mt$parent[i],coordi]
        #if (loga=="y") yparent<-mt$ycoor[mt$parent[i]] else 
        yparent<-mt$ycoor[mt$parent[i]]
        collo<-mt$colot[i]  #mt$parent[i]]
        segments(xparent,yparent,xchild,ychild,col=collo)
     }
}

}

plotprof<-function(profile,length=NULL,
plot=TRUE,data=FALSE,crit=NULL,orderrule="distcenter",
modelabel=TRUE,ptext=0,leimat=NULL,symbo=NULL,
info=NULL,infolift=0,infopos=0,
xmarginleft=0,xmarginright=0,ymargin=0,
xlim=NULL,ylim=NULL,
col="black",col.axis="black",
cutlev=NULL,xaxt="n",exmavisu=NULL,cex.axis=1,cex=1)
{

#xaxs="e"    (extended)  not implemented?  xaxt="n"

parents<-profile$parent
levels<-profile$level
if (is.null(length)) length<-profile$volume
center<-profile$center

mut<-multitree(parents)
if (is.null(profile$roots)) roots<-mut$roots else roots<-profile$roots
child<-mut$child
sibling<-mut$sibling

d<-dim(center)[1]
if (is.null(crit)){
   crit<-rep(0,d)          #order so that 1st closest to origo
   if (d==1) crit<-max(center)
   if (!is.null(profile$refe)) crit<-profile$refe
}

if (orderrule=="distcenter") sibord<-siborder(mut,crit,profile$distcenter)
else sibord<-siborder(mut,crit,center)

itemnum<-length(parents)
vecs<-matrix(NA,itemnum,4)
vecs<-alloroot(vecs,roots,sibord,levels,length)
vecs<-plotdata(roots,child,sibling,sibord,levels,length,vecs)
orivecs<-vecs

if (!(is.null(cutlev))){
  cm<-cutmut(mut,cutlev,levels)              # cut the tree
  roots<-cm$roots
  sibling<-cm$sibling
  mut$roots<-roots
  if (orderrule=="distcenter") sibord<-siborder(mut,crit,profile$distcenter)
  else sibord<-siborder(mut,crit,center)
  rootnum<-length(roots) 
  apuvecs<-matrix(NA,itemnum,4)
  for (i in 1:rootnum){
     inde<-roots[i]
     apuvecs[inde,]<-vecs[inde,]
  }
  vecs<-apuvecs          #we give for the roots the previous positions
  vecs<-plotdata(roots,child,sibling,sibord,levels,length,vecs)
}

if (plot==TRUE){
   if (!(is.null(cutlev))){
     xlim<-c(omamin(vecs[,1])-xmarginleft,omamax(vecs[,3])+xmarginright)
     ylim<-c(omamin(vecs[,2]),omamax(vecs[,2])+ptext+ymargin)
   }
   else{
     xlim<-c(omamin(vecs[,1])-xmarginleft,omamax(vecs[,3])+xmarginright)
     if (is.null(ylim)) ylim<-c(0,omamax(vecs[,2])+ptext+ymargin)
   }
   plotvecs(vecs,segme=T,xlim=xlim,ylim=ylim,xaxt=xaxt,
   col=col,col.axis=col.axis,cex.axis=cex.axis)
   # use original vectors (numbering will be correct)
   if (modelabel){
      plottext(parents,orivecs,ptext,leimat,symbo,cex=cex)  
   }
   if (!is.null(info)){
      plotinfo(vecs,info,pos=infopos,adj=NULL,lift=infolift,digits=3)
   }
}
#
#
if (data==TRUE){
 return(list(sibord=t(sibord),vecs=vecs,parents=parents,levels=levels,
 length=length,center=center,remain=NULL))
}

}












plottext<-function(parents,vecs,lift=0,leimat=NULL,symbo=NULL,cex=NULL){
#
mlkm<-moodilkm(parents)
modloc<-mlkm$modloc
#
nodenum<-length(vecs[,1])
xcoor<-matrix(0,2*nodenum,1)
ycoor<-matrix(0,2*nodenum,1)
#
for (i in 1:nodenum){
 xcoor[2*i-1]<-vecs[i,1]
 xcoor[2*i]<-vecs[i,3]
 ycoor[2*i-1]<-vecs[i,2]
 ycoor[2*i]<-vecs[i,4]
}                          
#
#mindiff<-vecs[nodenum,2]-vecs[1,2]
#for (i in 1:(nodenum-1)){
#  diff<-vecs[(i+1),2]-vecs[i,2]
#  if (diff>0) mindiff<-min(diff,mindiff)  
#}
#lift<-mindiff/5
#
moodinum<-length(modloc)
modelocx<-matrix(0,moodinum,1)
modelocy<-matrix(0,moodinum,1)
if (is.null(leimat)){
   if (is.null(symbo)){
       labels<-paste("M",1:moodinum,sep="")
   }
   else{
         if (symbo=="empty") labels<-paste("",1:moodinum,sep="")
         else  labels<-paste(symbo,1:moodinum,sep="")
   }
} 
else{
   labels<-leimat
}
xcor<-matrix(0,moodinum,1)
for (i in 1:moodinum){
    loc<-modloc[i] 
    xcor[i]<-xcoor[2*loc-1] 
}
modloc<-omaord2(modloc,xcor)
for (i in 1:moodinum){
    loc<-modloc[i] 
    modelocx[i]<-(xcoor[2*loc-1]+xcoor[2*loc])/2
    modelocy[i]<-ycoor[2*loc-1]+lift
}
text(modelocx,modelocy,labels=labels,cex=cex)
return(list(modelocx=modelocx,labels=labels))
}





plottree<-function(lst,
plot=T,data=F,crit=NULL,orderrule="distcenter",
modelabel=TRUE,ptext=0,leimat=NULL,symbo=NULL,
info=NULL,infolift=0,infopos=0,infochar=NULL,
xmarginleft=0,xmarginright=0,ymargin=0,
xlim=NULL,ylim=NULL,
col="black",col.axis="black",linecol=rep("black",length(lst$parent)),
pch=21,dimen=NULL,yaxt="s",axes=T,
cex=NULL,nodemag=NULL,linemag=1,cex.axis=1,ylab="",cex.lab=1,
colo=FALSE,paletti=NULL,lowest="dens")
{ 
# create vector verticalPos
# find modes, number of modes, attach vertical position to modes
# position of parent is the mid of positions of children:
# use multitree to find siblings of node and "parent" to fine parent
#
#pch=19: solid circle, pch=20: bullet (smaller circle), 
#pch=21: circle, pch=22: square, 
#pch=23: diamond, pch=24: triangle point-up, 
#pch=25: triangle point down. 

if (colo){
  if (is.null(paletti))
    paletti<-c("red","blue","green",
    "orange","navy","darkgreen",
    "orchid","aquamarine","turquoise",
    "pink","violet","magenta","chocolate","cyan",
    colors()[50:657],colors()[50:657])

  col<-colobary(lst$parent,paletti,modecolo=NULL,modepointer=NULL)
  linecol<-col
}
else col<-rep(col,length(lst$parent))

parent<-lst$parent
level<-lst$level
center<-lst$center
if (is.null(center)){
   nodenum<-length(parent)
   dimen<-length(lst$refe)
   nodenum<-length(lst$parent)
   center<-matrix(1,dimen,nodenum)
}
#      
mut<-multitree(parent)    #create multitree 
roots<-mut$roots
child<-mut$child
sibling<-mut$sibling 

if (is.null(dimen)){
  d<-dim(center)[1]
}
else{
  d<-dimen
}

if (is.null(crit)){
   crit<-rep(0,d)          #order so that 1st closest to origo
   if (d==1) crit<-max(center)
   if (!is.null(lst$refe)) crit<-lst$refe
}
if (orderrule=="distcenter") sibord<-siborder(mut,crit,lst$distcenter)
else sibord<-siborder(mut,crit,center)

mlkm<-moodilkm(parent)
modloc<-mlkm$modloc   
#mlkm$modnodes
modenum<-mlkm$lkm  

lst$center<-center
modelinks<-siborToModor(lst)        #make links in right order

itemnum<-length(parent)    
verticalPos<-matrix(0,itemnum,1)

step<-1/modenum
curloc<-0
for (i in 1:modenum){
   curmode<-modelinks[i]   
   verticalPos[curmode]<-curloc
   curloc<-curloc+step
} 


for (i in 1:modenum){
   curnode<-modloc[i]
   par<-parent[curnode]
   while (par>0){
      #calculate mid of children of par
      #go to the end of sibling list
        chi<-child[par]
        summa<-verticalPos[chi]
        childNum<-1
        while(sibling[chi]>0){
           chi<-sibling[chi]
           summa<-summa+verticalPos[chi]
           childNum<-childNum+1
        }                            
        verticalPos[par]<-summa/childNum
        par<-parent[par]
   }
}

if (lowest=="dens") lowesti<-0 else lowesti<-min(lst$level)
if (is.null(ylim)) ylim<-c(lowesti-ymargin,max(level)+ptext+ymargin)
xlim<-c(min(verticalPos)-xmarginleft,max(verticalPos)+xmarginright)
#axes<-
plot(verticalPos,level,xlab="",ylab=ylab,xlim=xlim,ylim=ylim,xaxt="n",
col=col,col.axis=col.axis,pch=pch,yaxt=yaxt,axes=axes,cex=nodemag,
cex.axis=cex.axis,cex.lab=cex.lab)  

for (i in 1:itemnum){
    if (parent[i]>0){
        xchild<-verticalPos[i]
        ychild<-level[i]
        xparent<-verticalPos[parent[i]]
        yparent<-level[parent[i]]
        segments(xparent,yparent,xchild,ychild,col=linecol[i],lwd=linemag)
     }
}                
#
# lets plot info
#
if (!is.null(info)){
   nodenum<-itemnum
   infolocx<-matrix(nodenum,1)
   infolocy<-matrix(nodenum,1)
   #
   for (i in 1:nodenum){
     infolocx[i]<-verticalPos[i] 
     infolocy[i]<-level[i]+infolift
   }
   digits<-3
   info<-format(info,digits=digits)
   adj<-NULL
   pos<-infopos
   text(infolocx,infolocy,info,pos,adj,cex=cex)       
}
#
# lets plot character info
#
if (!is.null(infochar)){
   nodenum<-itemnum
   infolocx<-matrix(nodenum,1)
   infolocy<-matrix(nodenum,1)
   #
   for (i in 1:nodenum){
     infolocx[i]<-verticalPos[i] 
     infolocy[i]<-level[i]+infolift
   }
   pos<-infopos
   text(infolocx,infolocy,infochar,pos,cex=cex)       
}
#
# lets plot labels for modes
#
if (modelabel){
#
xcoor<-verticalPos
ycoor<-level
#
mlkm<-moodilkm(parent)
modloc<-mlkm$modloc  
modenum<-length(modloc)
modelocx<-matrix(0,modenum,1)
modelocy<-matrix(0,modenum,1)
if (is.null(leimat)){
   if (is.null(symbo)){
       labels<-paste("M",1:modenum,sep="")
   }
   else{
      labels<-paste(symbo,1:modenum,sep="")
   }
}
else{
   labels<-leimat
}
xcor<-matrix(0,modenum,1)                       
for (i in 1:modenum){
    loc<-modloc[i]
    xcor[i]<-xcoor[loc]
}
modloc<-omaord2(modloc,xcor)
for (i in 1:modenum){
    loc<-modloc[i]
    modelocx[i]<-xcoor[loc]
    modelocy[i]<-ycoor[loc]+ptext
}
text(modelocx,modelocy,labels,cex=cex)      
##
}
###############
}









plottwin<-function(tt,et,lev,bary,orde="furthest",ordmet="etaisrec")
{

#if (is.null(et$low)){
   d<-length(et$N)
   step<-matrix(0,d,1)
   for (i in 1:d) step[i]=(et$support[2*i]-et$support[2*i-1])/et$N[i];
   et$step<-step
   et$low<-et$down
   et$upp<-et$high
#}

pp<-plotprof(tt,plot=FALSE,data=TRUE)
vecs<-pp$vecs

d<-length(et$step)

# order the atoms for the level set with level "lev"

lenni<-length(et$value)
distat<-matrix(0,lenni,1)
infopointer<-matrix(0,lenni,1)
lkm<-0
for (i in 1:lenni){
  if (et$value[i]>=lev){
     lkm<-lkm+1
     nod<-i  #nod<-et$nodefinder[i]
     if (ordmet=="etaisrec"){
         recci<-matrix(0,2*d,1)
         for (jj in 1:d){
            recci[2*jj-1]<-et$support[2*jj-1]+et$step[jj]*et$low[nod,jj]
            recci[2*jj]<-et$support[2*jj-1]+et$step[jj]*et$upp[nod,jj]
         }
         distat[lkm]<-etaisrec(bary,recci)
     }
     else{
         lowi<-matrix(0,d,1)
         uppi<-matrix(0,d,1)
         for (jj in 1:d){
            lowi[jj]<-et$support[2*jj-1]+et$step[jj]*et$low[nod,jj]
            uppi[jj]<-et$support[2*jj-1]+et$step[jj]*et$upp[nod,jj]
         }
         baryc<-lowi+(uppi-lowi)/2
         distat[lkm]<-etais(baryc,bary)  #etais(baryc[lk m,],baryind)
     }
     infopointer[lkm]<-i
  }
}
distat<-distat[1:lkm]
infopointer<-infopointer[1:lkm]   #pointe->et$value,et$nodefinder

ord<-order(distat)
infopointer<-infopointer[ord]

xmin<-et$support[1]
xmax<-et$support[2]
ymin<-et$support[3]
ymax<-et$support[4]
plot(x=bary[1],y=bary[2],xlab="",ylab="",xlim=c(xmin,xmax),ylim=c(ymin,ymax),
pch=20,col="red")

i<-1
while (i<=lkm){

     if (orde=="furthest") node<-lkm-i+1 else node<-i
     ip<-infopointer[node]   #ip<-et$nodefinder[infopointer[node]]

     x1<-et$support[1]+et$step[1]*et$low[ip,1]
     x2<-et$support[1]+et$step[1]*et$upp[ip,1] 
     y1<-et$support[3]+et$step[2]*et$low[ip,2]
     y2<-et$support[3]+et$step[2]*et$upp[ip,2] 
     polygon(c(x1,x2,x2,x1),c(y1,y1,y2,y2),col="lightblue")

     i<-i+1
}

xmin2<-min(vecs[,1])
xmax2<-max(vecs[,3])
ymin2<-0
ymax2<-omamax(vecs[,2])
x11()
plot("","",xlab="",ylab="",xlim=c(xmin2,xmax2),ylim=c(ymin2,ymax2))

ycor<-ymax
i<-1
while ((i<=lkm) && (ycor>ymin2)){

     if (orde=="furthest") node<-lkm-i+1 else node<-i
     ip<-infopointer[node]  #ip<-et$nodefinder[infopointer[node]]

     x1<-et$support[1]+et$step[1]*et$low[ip,1]
     x2<-et$support[1]+et$step[1]*et$upp[ip,1] 
     y1<-et$support[3]+et$step[2]*et$low[ip,2]
     y2<-et$support[3]+et$step[2]*et$upp[ip,2] 
     dev.set(which = dev.next())
     polygon(c(x1,x2,x2,x1),c(y1,y1,y2,y2),col="blue")
     points(x=bary[1],y=bary[2],pch=20,col="red")

     ttnode<-node     
     vecci<-vecs[ttnode,]
     x0<-vecci[1]
     y0<-vecci[2]
     x1<-vecci[3]
     y1<-vecci[4] 
     dev.set(which = dev.next())
     segments(x0, y0, x1, y1)

     loc<-locator(1)
     ycor<-loc$y 

     i<-i+1
}



}

plotvecs<-function(vecs,
depths=NULL,segme=T,lift=NULL,
modetest=NULL,alpha=NULL,
axes=T,xlim=NULL,ylim=NULL,xaxt=xaxt,col="black",col.axis="black",
modecolors=NULL,modethickness=1,
leafcolors=NULL,leaflift=0,leafsymbo=20,
modelabels=NULL,ptext=0,
yaxt="s",log="",cex.axis=1)
{
#Plots vectors in vec
#
#vecs is nodenum*4-matrix
#vecs[i,1] x-coordi alulle
#vecs[i,2] y-coordi alulle = vecs[i,4] y-coordi lopulle
#vecs[i,3] x-coordi lopulle
#
#plot(c(1,2),c(3,3))  
#segments(1,3,2,3)
#
#plot(c(1,2,3,4),c(3,3,2,2))  
#segments(1,3,2,3)
#segments(3,2,4,2)
#
#vecs<-matrix(0,3,4)    
#vecs[1,]<-c(1,1,4,1)
#vecs[2,]<-c(5,1,6,1)
#vecs[3,]<-c(2,2,3,2)
#
#plot(c(1,4,5,6,2,3),c(1,1,1,1,2,2))
#segments(1,1,4,1)
#segments(5,1,6,1)
#segments(2,2,3,2)

nodenum<-length(vecs[,1])
xcoor<-matrix(0,2*nodenum,1)
ycoor<-matrix(0,2*nodenum,1)

for (i in 1:nodenum){
 xcoor[2*i-1]<-vecs[i,1]
 xcoor[2*i]<-vecs[i,3]
 ycoor[2*i-1]<-vecs[i,2]
 ycoor[2*i]<-vecs[i,4]
}

#ylim<-c(0,max(ycoor)+ptext)
plot(xcoor,ycoor,xlab="",ylab="",axes=axes,xlim=xlim,ylim=ylim,xaxt=xaxt,
col=col,col.axis=col.axis,yaxt=yaxt,log=log,cex.axis=cex.axis)

if (!is.null(leafcolors)){
   xpoint<-matrix(0,nodenum,1)
   ypoint<-matrix(0,nodenum,1)
   leafcol<-matrix("",nodenum,1)
   zahl<-0
   for (no in 1:nodenum){
      if (leafcolors[no]!="black"){
          zahl<-zahl+1
          xpoint[zahl]<-vecs[no,1]+(vecs[no,3]-vecs[no,1])/2
         
          lif<-(depths[no]-1)*lift
          yc<-ycoor[2*no-1]+lif
          ypoint[zahl]<-yc+leaflift
         
          leafcol[zahl]<-leafcolors[no]
      }
   }
   xpoint<-xpoint[1:zahl]
   ypoint<-ypoint[1:zahl]
   leafcol<-leafcol[1:zahl]
   points(xpoint,ypoint,pch=leafsymbo,col=leafcol)
}

if (!is.null(modelabels)){
   for (no in 1:nodenum){
      if (modelabels[no]!=""){
          xpoint<-vecs[no,1]+(vecs[no,3]-vecs[no,1])/2
         
          lif<-(depths[no]-1)*lift
          yc<-ycoor[2*no-1]+lif
          ypoint<-yc+ptext
         
          label<-modelabels[no]
          
          text(xpoint,ypoint,label)

      }
   }
}

if (segme==T){
 
   thick<-1
   lif<-0
   col<-"black"   

   for (i in 1:nodenum){

        if (!is.null(depths))  lif<-(depths[i]-1)*lift
        if (!is.null(modecolors)){
                if (modecolors[i]!="black") thick=modethickness 
                                            #thick<-2.2^(depths[i]-1)  
                col<-modecolors[i]   
        }
        if (!is.null(modetest)){
             col<-4
             if (modetest[i]>0){
                if (modetest[i]>alpha)  col<-2   
                     #red, hyvaksytaan 0-hypoteesi=ei moodia
                     #nodes with red are not a real feature
                else col<-4   #blue
             } 
       }
           #testcrit<-modetest[i]*qnorm(1-alpha/2)
           #if (excmassa>testcrit)

        yc<-ycoor[2*i-1]+lif
        segments(xcoor[2*i-1],yc,xcoor[2*i],yc,col=col,lwd=thick)
        
        #lines(c(xcoor[2*i-1],xcoor[2*i]),c(ycoor[2*i-1],ycoor[2*i]),col=2) 
  
   }
}

#return(t(tc),t(em))
}











plotvolu2d<-function(vd,theta=NULL,phi=NULL,typer="flat")
{
# typer "dens"/"flat"

if (is.null(phi)) phi<-30

if (vd$type2=="slice"){

if (vd$type=="radius"){

 if (typer=="flat"){
     if (is.null(theta)) theta<-50
     persp(vd$x,vd$y,vd$z,
     xlab="level",ylab="",zlab="radius",ticktype="detailed",
     phi=phi,theta=theta)
 }
 else{
     levnum<-length(vd$x)
     ynumold<-length(vd$y)
     maksi<-max(vd$z)
     gnum<-100
     step<-maksi/(gnum-1)
     xnew<-seq(0,maksi,step)
     znew<-matrix(0,gnum,ynumold)
     for (i in 1:levnum){
        for (j in 1:ynumold){
           highness<-round(gnum*vd$z[i,j]/maksi)
           znew[1:highness,j]<-vd$x[i]  #level[i]
        }
     }
     if (is.null(theta)) theta<-40
     persp(xnew,vd$y,znew,
     xlab="radius",ylab="",zlab="level",
     ticktype="detailed",
     phi=phi,theta=theta)
 }
}

if (vd$type=="proba"){
if (is.null(theta)) theta<--130
if (vd$norma) xlab<-"normalized volume" else xlab<-"volume"
persp(vd$x,vd$y,vd$z,
xlab=xlab,ylab="",zlab="radius",ticktype="detailed",
phi=phi,theta=theta)
}

}   #type2=="slice"

else{ #type2=="boundary"

if (is.null(theta)) theta<-50
persp(vd$x,vd$y,vd$z,
xlab="",ylab="",zlab="level",ticktype="detailed",
phi=phi,theta=theta)

}


}




plotvolu.new<-function(lst,dens=TRUE)
{
mt<-multitree(lst$parent)
itemnum<-length(lst$volume)
rootnum<-length(mt$roots)
left<-mt$child
right<-mt$sibling
vecs<-matrix(0,itemnum,3)

sibord<-mt$siborder  #siborder.new(mt)

# allocate space for roots

rootsvolume<-0
for (i in 1:rootnum){
  now<-mt$roots[i]
  rootsvolume<-rootsvolume+lst$volume[now]
}
basis<-rootsvolume+rootsvolume/4
gaplen<-(basis-rootsvolume)/(rootnum+1)
rootlinks<-matrix(0,rootnum,1)  #make links in right order
{
if (rootnum==1){ 
  rootlinks[1]<-1
}
else{ 
     for (i in 1:rootnum){
         now<-mt$roots[i]
         roor<-sibord[now]
         rootlinks[roor]<-now
     }
}
xbeg<-0
xend<-0
for (i in 1:rootnum){
  now<-rootlinks[i]
  ycoo<-lst$level[now]
  xend<-xbeg+lst$volume[now]
  vecs[now,]<-c(xbeg,xend,ycoo)
  xbeg<-gaplen+xend
}
}
# allocate space for nonroots

for (i in 1:rootnum){
    pino<-matrix(0,itemnum,1)
    pino[1]<-mt$roots[i]  
    pinin<-1
    while (pinin>0){
        cur<-pino[pinin]      #take from stack
        pinin<-pinin-1
        if (left[cur]>0){     #if not leaf (root may be leaf)
           vecs<-allokoi.new(cur,vecs,lst,left,right,sibord)   
        }
        if (right[cur]>0){    #if right exists, put to stack
            pinin<-pinin+1
            pino[pinin]<-right[cur]
        }
        while (left[cur]>0){    #go to leaf and put right nodes to stack
             cur<-left[cur]
             if (left[cur]>0){  #if not leaf
                vecs<-allokoi.new(cur,vecs,lst,left,right,sibord)
             }
             if (right[cur]>0){ #if right exists, put to stack
                pinin<-pinin+1
                pino[pinin]<-right[cur]
             }
        }
    }
} 
      
if (dens) firstlevel<-0 else firstlevel<-min(lst$level)
xlim<-c(min(vecs[,1]),max(vecs[,2]))
ylim<-c(firstlevel,max(lst$level))
plot(x="",y="",xlab="",ylab="",xlim=xlim,ylim=ylim)

for (i in 1:itemnum){

    yc<-vecs[i,3]

    pare<-lst$parent[i]
    if (pare==0) lowlev<-firstlevel else lowlev<-lst$level[pare]

    segments(vecs[i,1],lowlev,vecs[i,1],yc)#,col=col,lwd=thick)
    segments(vecs[i,2],lowlev,vecs[i,2],yc)#,col=col,lwd=thick)

    if (left[i]==0){  #we are in leaf

       segments(vecs[i,1],yc,vecs[i,2],yc)#,col=col,lwd=thick)

    }
    else{

       childnum<-1
       curchi<-mt$child[i]
       while (mt$sibling[curchi]!=0){
           curchi<-mt$sibling[curchi]
           childnum<-childnum+1
       }

       sibpointer<-matrix(0,childnum,1)
       curchi<-mt$child[i]
       sibpointer[sibord[curchi]]<-curchi
       while (mt$sibling[curchi]!=0){
           curchi<-mt$sibling[curchi]
           sibpointer[sibord[curchi]]<-curchi
       }

       curchi<-sibpointer[1]
       x1<-vecs[curchi,1]      
       segments(vecs[i,1],yc,x1,yc)#,col=col,lwd=thick)
       x0<-vecs[curchi,2]

       cn<-2
       while (cn<=childnum){
             curchi<-sibpointer[cn]
             x1<-vecs[curchi,1] 
             segments(x0,yc,x1,yc)#,col=col,lwd=thick)
             x0<-vecs[curchi,2] 
             cn<-cn+1
       }

       segments(x0,yc,vecs[i,2],yc)#,col=col,lwd=thick)

    }
}


}





plotvolu<-function(lst,length=NULL,
toplot=TRUE,data=FALSE,crit=NULL,orderrule="distcenter",
modelabel=FALSE,ptext=0,leimat=NULL,symbo=NULL,
info=NULL,infolift=0,infopos=0,
xmarginleft=0,xmarginright=0,ymargin=0,
xlim=NULL,ylim=NULL,
col="black",col.axis="black",
cutlev=NULL,xaxt="s",yaxt="s",
exmavisu=NULL,bg="transparent",tyyppi="n",
lty="solid",colo=FALSE,lowest="dens",proba=FALSE,
paletti=NULL,cex=NULL,modecolo=NULL,modepointer=NULL,upper=TRUE,
cex.axis=1)
{
if (upper) firstlevel<-min(lst$level) else firstlevel<-max(lst$level)
if (lowest=="dens") firstlevel<-0

parents<-lst$parent
levels<-lst$level
length<-lst$volume
if (proba) length<-lst$proba
center<-lst$center

mut<-multitree(parents)
if (is.null(lst$roots)) roots<-mut$roots else roots<-lst$roots
child<-mut$child
sibling<-mut$sibling

d<-dim(center)[1]
if (is.null(crit)){
   crit<-rep(0,d)          #order so that 1st closest to origo
   if (d==1) crit<-max(center)
   if (!is.null(lst$refe)) crit<-lst$refe
}

if (orderrule=="distcenter") sibord<-siborder(mut,crit,lst$distcenter)
else sibord<-siborder(mut,crit,center)

itemnum<-length(parents)
vecs<-matrix(NA,itemnum,4)
vecs<-alloroot(vecs,roots,sibord,levels,length)
vecs<-plotdata(roots,child,sibling,sibord,levels,length,vecs)
orivecs<-vecs

if (!(is.null(cutlev))){
  cm<-cutmut(mut,cutlev,levels)              # cut the tree
  roots<-cm$roots
  sibling<-cm$sibling
  mut$roots<-roots
  if (orderrule=="distcenter") sibord<-siborder(mut,crit,lst$distcenter)
  else sibord<-siborder(mut,crit,center)
  rootnum<-length(roots) 
  apuvecs<-matrix(NA,itemnum,4)
  for (i in 1:rootnum){
     inde<-roots[i]
     apuvecs[inde,]<-vecs[inde,]
     if (i==1) miniroot<-apuvecs[inde,1]
     else if (apuvecs[inde,1]<=miniroot) miniroot<-apuvecs[inde,1]
  }
  vecs<-apuvecs          #we give for the roots the previous positions
  vecs<-plotdata(roots,child,sibling,sibord,levels,length,vecs)
}

#####################################

depths<-NULL
segme<-T
lift<-NULL
modetest<-NULL
alpha<-NULL
axes<-T
modecolors<-NULL
modethickness<-1
leafcolors<-NULL
leaflift<-0
leafsymbo<-20
modelabels<-NULL
log<-""

nodenum<-length(vecs[,1])
xcoor<-matrix(0,2*nodenum,1)
ycoor<-matrix(0,2*nodenum,1)

for (i in 1:nodenum){
 xcoor[2*i-1]<-vecs[i,1]
 xcoor[2*i]<-vecs[i,3]
 ycoor[2*i-1]<-vecs[i,2]
 ycoor[2*i]<-vecs[i,4]
}

oriminnu<-min(orivecs[,1],na.rm=T)
minnu<-min(xcoor,na.rm=T)
if (is.null(cutlev)) xcoor<-xcoor-minnu
else xcoor<-xcoor-oriminnu


if (lowest=="dens") lowesti<-0 else lowesti<-min(lst$level)
#xlim<-c(min(vecs[,1],na.rm=T)-xmarginleft,max(vecs[,3],na.rm=T)+xmarginright)
if (is.null(ylim)) ylim<-c(lowesti,max(ycoor,na.rm=T)+ptext+ymargin)
if (!is.null(cutlev)) ylim<-c(cutlev,max(ycoor,na.rm=T)+ptext+ymargin)

if (toplot){
par(bg=bg)
plot(xcoor[order(xcoor)],ycoor[order(xcoor)],  #xcoor,ycoor,
xlab="",ylab="",axes=axes,xlim=xlim,ylim=ylim,xaxt=xaxt,
col=col,col.axis=col.axis,yaxt=yaxt,log=log,
type=tyyppi,lty=lty,cex.axis=cex.axis)
}
###########################################################

if ((tyyppi=="n") && (toplot)){

thick<-1
col<-col #"black"

for (i in 1:nodenum){
if (!is.na(ycoor[2*i-1])){

    yc<-ycoor[2*i-1]

    pare<-parents[i]
    if (pare==0) lowlev<-firstlevel else lowlev<-levels[pare]

    segments(xcoor[2*i-1],lowlev,xcoor[2*i-1],yc,col=col,lwd=thick)
    segments(xcoor[2*i],lowlev,xcoor[2*i],yc,col=col,lwd=thick)

    if (child[i]==0){  #we are in leaf

       segments(xcoor[2*i-1],yc,xcoor[2*i],yc,col=col,lwd=thick)

    }
    else{

       yc<-ycoor[2*i-1]

       childnum<-1
       curchi<-child[i]
       while (sibling[curchi]!=0){
           curchi<-sibling[curchi]
           childnum<-childnum+1
       }

       sibpointer<-matrix(0,childnum,1)
       curchi<-child[i]
       sibpointer[sibord[curchi]]<-curchi
       while (sibling[curchi]!=0){
           curchi<-sibling[curchi]
           sibpointer[sibord[curchi]]<-curchi
       }

       curchi<-sibpointer[1]
       x1<-xcoor[2*curchi-1]      
       segments(xcoor[2*i-1],yc,x1,yc,col=col,lwd=thick)
       x0<-xcoor[2*curchi] 

       cn<-2
       while (cn<=childnum){
             curchi<-sibpointer[cn]
             x1<-xcoor[2*curchi-1] 
             segments(x0,yc,x1,yc,col=col,lwd=thick)
             x0<-xcoor[2*curchi] 
             cn<-cn+1
       }

       segments(x0,yc,xcoor[2*i],yc,col=col,lwd=thick)

    }
}
}

for (i in 1:nodenum){
   if (is.null(cutlev)){
     orivecs[i,1]<-orivecs[i,1]-minnu
     orivecs[i,3]<-orivecs[i,3]-minnu
   }
   else{
     orivecs[i,1]<-orivecs[i,1]-oriminnu
     orivecs[i,3]<-orivecs[i,3]-oriminnu
   }
}   
if (modelabel) 
modelab<-plottext(parents,orivecs,ptext,leimat,symbo=symbo,cex=cex)  


}  #tyyppi = "n"


if (!is.null(lst$predictor.node)) 
segments(
xcoor[2*lst$predictor.node-1],
ycoor[2*lst$predictor.node-1],
xcoor[2*lst$predictor.node],
ycoor[2*lst$predictor.node])



############################################# exmavisu start

if (colo) exmavisu<-roots #1

if (!is.null(exmavisu)){

if (colo){
  if (is.null(paletti))
    paletti<-c("red","blue","green",
    "orange","navy","darkgreen",
    "orchid","aquamarine","turquoise",
    "pink","violet","magenta","chocolate","cyan",
    colors()[50:657],colors()[50:657])

  col<-colobary(lst$parent,paletti,modecolo=modecolo,modepointer=modepointer)
}
else col<-rep("blue",length(lst$parent))

for (i in 1:length(exmavisu)){

node<-exmavisu[i]

x1<-xcoor[2*node-1] 
x2<-xcoor[2*node]
lev<-levels[node]
if (parents[node]>0) lev0<-levels[parents[node]] else lev0<-firstlevel
polygon(c(x1,x2,x2,x1),c(lev0,lev0,lev,lev),col=col[node],lty="blank")

pino<-matrix(0,nodenum,1)
pino[1]<-child[node]
if (child[node]>0) pinoin<-1 else pinoin<-0

while (pinoin>0){
   node<-pino[pinoin]
   pinoin<-pinoin-1   

   x1<-xcoor[2*node-1] 
   x2<-xcoor[2*node]
   lev<-levels[node]
   if (parents[node]>0) lev0<-levels[parents[node]] else lev0<-firstlevel
   polygon(c(x1,x2,x2,x1),c(lev0,lev0,lev,lev),col=col[node],lty="blank")

   if (sibling[node]>0){
         pinoin<-pinoin+1
         pino[pinoin]<-sibling[node] 
   }

   while (child[node]>0){    #go to left and put right nodes to stack
         node<-child[node]

         x1<-xcoor[2*node-1] 
         x2<-xcoor[2*node]
         lev<-levels[node]
         if (parents[node]>0) lev0<-levels[parents[node]] else lev0<-firstlevel
         polygon(c(x1,x2,x2,x1),c(lev0,lev0,lev,lev),col=col[node],lty="blank")

         if (sibling[node]>0){
            pinoin<-pinoin+1
            pino[pinoin]<-sibling[node] 
         }
   }
}
}
}
####################### exmavisu end

if (data) return(list(xcoor=xcoor,ycoor=ycoor))


}





point.eval<-function(tr,x)
{
# tr is an evaluation tree

d<-length(tr$support)/2
step<-matrix(0,d,1)
for (i in 1:d) step[i]<-(tr$support[2*i]-tr$support[2*i-1])/tr$N[i]

# if x is not in the support, then ans=0
insupport<-1
for (i in 1:d){
    if ((x[i]>=tr$support[2*i]) || (x[i]<=tr$support[2*i-1])){
       ans<-0
       insupport<-0
    }
}
if (insupport){
  node<-1
  while (tr$left[node]>0){
      dir<-tr$direc[node]
      spl<-tr$split[node]
      realspl<-tr$support[2*dir-1]+spl*step[dir]
      if (x[dir]>realspl) node<-tr$right[node]
      else node<-tr$left[node]
  }
  #loc<-tr$infopointer[node]
  #ans<-tr$value[loc]
  ans<-tr$mean[node]
}

return(ans)
}
pp.plot<-function(dendat=NULL,compa="gauss",basis="gauss",mean=0,sig=1,df=1,
gnum=1000,d=1,R=3,pptype="1d",cex.lab=1,cex.axis=1,col="blue",lwd=1)
# basis is either data (dendat) or a theoretical distribution
{
if (pptype=="1d"){
   p<-dendat[order(dendat)]
   if (compa=="gauss") y<-pnorm(p,mean=mean,sd=sig)
   if (compa=="student") y<-pt((p-mean)/sig,df=df)
   if (compa=="unif") y<-punif((p-mean)/sig)
   if (compa=="exp") y<-pexp((p-mean)/sig)
   if (compa=="doubleexp") 
      y<-0.5*(1-pexp(-(p-mean)/sig))+0.5*pexp((p-mean)/sig)
   n<-length(dendat) #dim(dendat)[1]
   x<-seq(1:n)/n
   tyyppi<-"p"
   xlab<-"empirical distribution function"
   ylab<-"compared distribution function"
}
if (pptype=="v2p"){
      rp<-tailfunc(R,d,type=compa,gnum=gnum,sig=sig,nu=df)
      y<-rp$proba
      rp2<-tailfunc(R,d,type=basis,gnum=gnum,sig=sig,nu=df)
      x<-rp2$proba
      tyyppi="l"
      xlab<-"empirical"
      ylab<-"model"
}
if (pptype=="ddplot"){
}

plot(x,y,
type=tyyppi,
xlim=c(0,1),ylim=c(0,1),
xlab=xlab,ylab=ylab,cex.lab=cex.lab,cex.axis=cex.axis)
segments(0,0,1,1,col=col,lwd=lwd)
}

preprocess<-function(dendat, type="copula")
{
n<-dim(dendat)[1]
d<-dim(dendat)[2]
prodendat<-matrix(0,n,d)

if (type=="sphering"){

   cova<-cov(dendat)
   eig<-eigen(cova,symmetric=TRUE)
   sigsqm<-eig$vectors%*%diag(eig$values^{-1/2}) 
   prodendat<-t(t(sigsqm)%*%t(dendat-mean(dendat)))   # dendat%*%sigsqm 

}
else if (type=="standardcopula"){
   for (ii in 1:d){
        or<-order(dendat[,ii])
        mones<-matrix(0,n,1)
        for (i in 1:n) mones[or[i]]<-i
        prodendat[,ii]<-mones/n
   }

}
else{
   for (ii in 1:d){
        or<-order(dendat[,ii])
        mones<-matrix(0,n,1)
        for (i in 1:n) mones[or[i]]<-i
        prodendat[,ii]<-qnorm(mones/n)
   }
}

return(prodendat)
}
prof2vecs<-function(profile,level,n=NULL,crit,motes=NULL){

parents<-profile$parent
nodenum<-length(parents)
centers<-profile$center
 
nodenum<-length(parents)   
levels<-matrix(level,nodenum,1) #all will be plotted at same lev(=logh)
excma<-excmas(profile)       #instead of volumes, we use excesss mass
                             #to determine the lengths of the vectors
#motes<-mtest(profile,n)

mut<-multitree(parents)

# let us make a vector where modes are labelled with the order, others=0
# later we handle "mlabel" similarily as "motes"
mlabel<-matrix(0,nodenum,1)
mlkm<-moodilkm(parents)      #mlkm$lkm, mlkm$modloc 
for (run in 1:mlkm$lkm){
   alku<-mlkm$modloc[run]
   while ((parents[alku]>0) && 
          (mut$sibling[mut$child[parents[alku]]]==0)){
      alku<-parents[alku]
   }
   mlabel[alku]<-run  
}

mt<-pruneprof(mut)
depths<-depth(mt)
roots<-mt$roots
child<-mt$child
sibling<-mt$sibling

sibord<-siborder(mt,crit,centers)

itemnum<-length(parents)
vecs<-matrix(NA,itemnum,4)  
vecs<-alloroot(vecs,roots,sibord,levels,excma) 
vecs<-plotdata(roots,child,sibling,sibord,levels,excma,vecs)
vecnum<-length(vecs[,1])      #vecs has four columns

#  remove pruned

if (is.null(motes)) motes<-matrix(0,vecnum,1)

tempvecs<-matrix(0,vecnum,4)
tempdepths<-matrix(0,vecnum,1)
tempmotes<-matrix(0,vecnum,1)
tempmlabel<-matrix(0,vecnum,1)
ind<-0
for (i in 1:vecnum){
       if (!(is.na(vecs[i,1]))){
             ind<-ind+1
             tempvecs[ind,]<-vecs[i,]
             tempdepths[ind]<-depths[i]
             tempmotes[ind]<-motes[i]
             tempmlabel[ind]<-mlabel[i]
         }
}
vecs<-tempvecs[1:ind,]
depths<-tempdepths[1:ind]
motes<-tempmotes[1:ind]
mlabel<-tempmlabel[1:ind]

return(list(vecs=vecs,depths=depths,motes=motes,mlabel=mlabel))
}                        





profgene<-function(values,recs,frekv=NULL,cvol=TRUE,ccen=TRUE,cfre=FALSE,
outlsets=TRUE,invalue=TRUE)
{

cu<-cumu(values,recs,frekv)
levels<-cu$levels
lsets<-cu$lsets
atoms<-cu$atoms
binfrek<-cu$frekv  #kullekin suorakaiteelle frekvenssi

alkublokki<-200
blokki<-50
links<-toucrec(atoms,alkublokki,blokki)

alkublokki2<-200
blokki2<-50
dentree<-decom(lsets,levels,links,alkublokki2,blokki2)
seplsets<-dentree$lsets
sepval<-dentree$levels
parents<-dentree$parents

if (cfre) nodefrek<-cfrekv(seplsets,binfrek) else nodefrek<-NULL 

if (ccen==TRUE) cvol<-TRUE
if (cvol){
  volum<-cvolum(seplsets,atoms)
  kerroin<-cinte(sepval,volum,parents) 
  sepvalnor<-sepval/kerroin
} 
else{  
  volum<-NULL
  sepvalnor<-NULL
}

if (ccen && cvol) centers<-ccente(seplsets,atoms,volum) else centers<-NULL

if (!(outlsets)) seplsets<-NULL
if (!(invalue)) sepval<-NULL

return(list(parent=parents,level=sepvalnor,invalue=sepval,
volume=volum,center=centers,nodefrek=nodefrek,lsets=seplsets))
#values: normeeratut arvot
#invalues: alkuperaiset frekvenssit/arvot 
#nodefrek: kunkin solmun frekvenssi
}

















profhist<-function(dendat,binlkm,cvol=TRUE,ccen=TRUE,cfre=FALSE)
{
#esim. dendat<-matrix(rnorm(20),10) on 10*2 matriisi

epsi<-0
hi<-histo(dendat,binlkm,epsi)
recs<-hi$recs
hisfrekv<-hi$values

pr<-profgene(values=hisfrekv,recs=recs,frekv=hisfrekv,cvol=cvol,ccen=ccen,
cfre=cfre)

return(list(parent=pr$parent,level=pr$level,invalue=pr$invalue,
volume=pr$volum,center=pr$center,nodefrek=pr$nodefrek,recs=recs,
hisfrekv=t(hisfrekv),lsets=pr$lsets))
}










profkernC<-function(dendat,h,N,Q,cvol=TRUE,ccen=TRUE,#cfre=FALSE,
numofallR=10000){

#set.seed(seed=1)
#dendat<-matrix(rnorm(20),10)
#h<-1 
#N<-c(8,8)
#Q<-3

n<-dim(dendat)[1]
d<-length(N)
hnum<-length(h)
mnn<-maxnodenum(dendat,h,N,n,d)
extMaxnode<-mnn$maxnode
extMaxvals<-mnn$maxpositive

if (hnum>1){
 inh<-matrix(0,hnum+1,1)
 inh[2:(hnum+1)]<-h
}
else{
 inh<-h
}
inN<-matrix(0,d+1,1)
inN[2:(d+1)]<-N

dentree<-.C("kerprofC",as.integer(extMaxnode),
                  as.integer(extMaxvals),
                  as.double(dendat),
                  as.double(inh),
                  as.integer(inN),
                  as.integer(n),
                  as.integer(hnum),
                  as.integer(d),
                  as.integer(Q),
                  as.integer(numofallR),
                  level = double(numofallR+1),
                  parent = integer(numofallR+1),
                  component = integer(numofallR+1),
                  volume = double(numofallR+1),
                  center = double(d*numofallR+1),
                  efek = integer(1),
PACKAGE="denpro")

invalue<-dentree$level[2:(dentree$efek+1)]
parent<-dentree$parent[2:(dentree$efek+1)]
volume<-dentree$volume[2:(dentree$efek+1)]
kerroin<-cinte(invalue,volume,parent) 
sepvalnor<-invalue/kerroin
veccenter<-dentree$center[2:(d*dentree$efek+1)]
center<-matrix(0,dentree$efek,d)
for (i in 1:dentree$efek){
  for (j in 1:d){
     center[i,j]<-veccenter[(i-1)*d+j]
  }
}
center<-t(center)

#if (cfre) nodefrek<-cfrekvdya(seplsets,binfrek) else nodefrek<-NULL 

#clus<-F
#if (clus){
#   clustervecs<-cluskern(compo,component,AtomlistAtom,AtomlistNext,kg,dendat,
#   h,N)
#}
#else{
#   clustervecs<-NULL
#}

return(list(parent=parent,level=sepvalnor,invalue=invalue,
volume=volume,center=center))
#,nodefrek=nodefrek,clustervec=clustervecs))
#
#values: normeeratut arvot
#invalues: normeeraamattomat arvot 
#nodefrek: kunkin solmun frekvenssi
}









profkernCRC<-function(dendat,h,N,Q,cvol=TRUE,ccen=TRUE,#cfre=FALSE,
kernel="epane",compoinfo=FALSE,trunc=3,threshold=0.0000001,katka=NULL,hw=NULL)
{
#dyn.load("/home/jsk/kerle/kerleCversio")
#pk2<-profkernCRC(dendat,h,N,Q)
#
#set.seed(seed=1)
#dendat<-matrix(rnorm(20),10)
#h<-1 
#N<-c(8,8)
#Q<-3
#
n<-dim(dendat)[1]
d<-length(N)

if (is.null(hw)) weig<-rep(1/n,n) 
else{
   weig<-weightsit(n,hw)

   dendatnew<-dendat
   weignew<-weig
   cumul<-0
   for (i in 1:n){
        if (weig[i]>0){
            cumul<-cumul+1
            dendatnew[cumul,]<-dendat[i,]
            weignew[cumul]<-weig[i] 
        }
   }
   dendat<-dendatnew[1:cumul,]
   weig<-weignew[1:cumul]
   n<-cumul
}
inweig<-matrix(0,n+1,1)
inweig[2:(n+1)]<-weig

hnum<-length(h)
mnn<-maxnodenum(dendat,h,N,n,d)
extMaxnode<-mnn$maxnode
extMaxvals<-mnn$maxpositive
#
if (hnum>1){
 inh<-matrix(0,hnum+1,1)
 inh[2:(hnum+1)]<-h
}
else{
 inh<-h
}
inN<-matrix(0,d+1,1)
inN[2:(d+1)]<-N

if (kernel=="epane") kertype<-1
else kertype<-2  # gaussian

kg<-.C("kergrid",
               as.integer(extMaxnode),
               as.integer(extMaxvals),
               as.double(dendat),
               as.double(inh),
               as.integer(inN),
               as.integer(n),
               as.integer(hnum),
               as.integer(d),
               as.integer(kertype),
               as.double(trunc),
               as.double(threshold),  
               as.double(inweig),        
               ioleft = integer(extMaxnode+1),
               ioright = integer(extMaxnode+1),
               ioparent = integer(extMaxnode+1),
               infopointer = integer(extMaxnode+1),
               iolow = integer(extMaxnode+1),
               ioupp = integer(extMaxnode+1),
               value = double(hnum*extMaxvals),
               index = integer(d*extMaxvals),
               nodefinder = integer(extMaxvals),
               numpositive = integer(1),
               numnode = integer(1),
PACKAGE="denpro")

left<-kg$ioleft[2:(kg$numnode+1)]
right<-kg$ioright[2:(kg$numnode+1)]
parent<-kg$ioparent[2:(kg$numnode+1)]
infopointer<-kg$infopointer[2:(kg$numnode+1)]
iolow<-kg$iolow[2:(kg$numnode+1)]
ioupp<-kg$ioupp[2:(kg$numnode+1)]

value<-kg$value[2:(kg$numpositive+1)]
nodefinder<-kg$nodefinder[2:(kg$numpositive+1)]
vecindex<-kg$index[2:(d*kg$numpositive+1)]
index<-matrix(0,kg$numpositive,d)
for (i in 1:kg$numpositive){
  for (j in 1:d){
     index[i,j]<-vecindex[(i-1)*d+j]
  }
}

nodenumOfDyaker<-length(left)

maxval<-max(value)
minval<-min(value)
step<-(maxval-minval)/Q
levseq<-seq(from=minval,to=maxval-step,by=step)

levfrekv<-matrix(0,Q,1)
atomnum<-length(value)
for (i in 1:atomnum){
   for (j in 1:Q){
       if (value[i]>=levseq[j]){
          levfrekv[j]<-levfrekv[j]+1
       }
   }
}
numofall<-sum(levfrekv)
levnum<-length(levseq)
    
inlevseq<-matrix(0,length(levseq)+1,1)
inlevseq[2:(length(levseq)+1)]<-levseq
inN<-matrix(0,d+1,1)
inN[2:(d+1)]<-N
inleft<-matrix(0,length(left)+1,1)
inleft[2:(length(left)+1)]<-left
inright<-matrix(0,length(left)+1,1)
inright[2:(length(left)+1)]<-right
inparent<-matrix(0,length(left)+1,1)
inparent[2:(length(left)+1)]<-parent
invalue<-matrix(0,length(value)+1,1)
invalue[2:(length(value)+1)]<-value
#inindex<-matrix(0,dim(kg$index)[1]+1,dim(kg$index)[2]+1)
#for (i in 1:dim(kg$index)[1]){
#  inindex[i+1,]<-c(0,kg$index[i,])
#}
innodefinder<-matrix(0,length(nodefinder)+1,1)
innodefinder[2:(length(nodefinder)+1)]<-nodefinder

# Tama koodi on jo kergrid:ssa, lasketaan volume of one atom
minim<-matrix(0,d,1)  #minim is d-vector of minimums
maxim<-matrix(0,d,1)
for (i in 1:d){
  minim[i]<-min(dendat[,i])
  maxim[i]<-max(dendat[,i])
}
delta<-(maxim-minim+2*h)/(N+1)  
volofatom<-prod(delta)

inminim<-matrix(0,d+1,1)
inminim[2:(d+1)]<-minim
indelta<-matrix(0,d+1,1)
indelta[2:(d+1)]<-delta

if (!is.null(katka)){
   invalue2<-invalue
   lenni<-length(invalue)
   for (i in 1:lenni){
      if (invalue[i]>=katka) invalue2[i]<-katka
   }
   invalue<-invalue2
}

dentree<-.C("decomdyaC",
               as.integer(numofall),
               as.integer(atomnum),
               as.double(inlevseq),
               as.integer(inN),
               as.integer(d),         
               as.integer(levnum),   
               as.double(volofatom),
               as.double(inminim),
               as.double(h),
               as.double(indelta),
               as.integer(nodenumOfDyaker),
               as.integer(inleft),
               as.integer(inright),
               as.integer(inparent), 
               as.double(invalue),
               as.integer(index),
               as.integer(innodefinder),
               level = double(numofall+1),
               parent = integer(numofall+1),
               component = integer(numofall+1),
               volume = double(numofall+1),
               center = double(d*numofall+1),
               efek = integer(1),
               AtomlistAtom = integer(numofall+1),
               AtomlistNext = integer(numofall+1),
               numOfAtoms = integer(1),
PACKAGE="denpro")

AtomlistAtom<-dentree$AtomlistAtom[2:(dentree$numOfAtoms+1)]
AtomlistNext<-dentree$AtomlistNext[2:(dentree$numOfAtoms+1)]

invalue<-dentree$level[2:(dentree$efek+1)]
parent<-dentree$parent[2:(dentree$efek+1)]
volume<-dentree$volume[2:(dentree$efek+1)]
component<-dentree$component[2:(dentree$efek+1)]
kerroin<-cinte(invalue,volume,parent) 
sepvalnor<-invalue/kerroin
veccenter<-dentree$center[2:(d*dentree$efek+1)]
center<-matrix(0,dentree$efek,d)
for (i in 1:dentree$efek){
  for (j in 1:d){
     center[i,j]<-veccenter[(i-1)*d+j]
  }
}
center<-t(center)

#if (cfre) nodefrek<-cfrekvdya(seplsets,binfrek) else nodefrek<-NULL 

#clus<-F
#if (clus){
#   clustervecs<-cluskern(compo,component,AtomlistAtom,AtomlistNext,kg,dendat,
#   h,N)
#}
#else{
#   clustervecs<-NULL
#}

if (compoinfo)

  return(list(parent=parent,level=sepvalnor,invalue=invalue,
  volume=volume,center=center,
  component=component,
  AtomlistAtom=AtomlistAtom,AtomlistNext=AtomlistNext,index=index))

else

  return(list(parent=parent,level=sepvalnor,invalue=invalue,
  volume=volume,center=center,n=n))

#,nodefrek=nodefrek,clustervec=clustervecs))
#
#values: normeeratut arvot
#invalues: normeeraamattomat arvot 
#nodefrek: kunkin solmun frekvenssi

}












profkern<-function(dendat,h,N,Q,cvol=TRUE,ccen=TRUE,cfre=FALSE,kernel="epane",
compoinfo=FALSE,trunc=3,threshold=0.0000001,sorsa="crc",hw=NULL)
{

if (kernel=="gauss") h<-h*trunc   #trunc<-3

hnum<-length(h)
hrun<-1
while (hrun<=hnum){
   hcur<-h[hrun]

   if (sorsa=="crc")
   curtree<-profkernCRC(dendat,hcur,N,Q,kernel=kernel,compoinfo=compoinfo,
            trunc=trunc,threshold=threshold,hw=hw)
   else
   curtree<-profkernC(dendat,hcur,N,Q)

   if (hrun==1){
      if (hnum==1){
          treelist<-curtree
      }
      else{
          treelist=list(curtree)
      }
   }
   else{
      treelist=c(treelist,list(curtree))
   }
   hrun<-hrun+1
}
#
return(treelist)
}
profkernR<-function(kg,dendat,h,N,Q,frekv=NULL,cvol=TRUE,ccen=TRUE,cfre=FALSE){

#set.seed(seed=1)
#dendat<-matrix(rnorm(20),10)
#h<-1 
#N<-c(4,4)
#Q<-3

#kg<-kergrid(dendat,h,N)

nodenumOfDyaker<-length(kg$left)

value<-kg$value
maxval<-max(value)
minval<-min(value)
step<-(maxval-minval)/Q
levseq<-seq(from=minval,to=maxval-step,by=step)

levfrekv<-matrix(0,Q,1)
atomnum<-length(value)
for (i in 1:atomnum){
   for (j in 1:Q){
       if (value[i]>=levseq[j]){
          levfrekv[j]<-levfrekv[j]+1
       }
   }
}
numofall<-sum(levfrekv)
    
dentree<-decomdya(numofall,atomnum,levseq,kg,N,nodenumOfDyaker)
invalue<-dentree$level
parent<-dentree$parent
component<-dentree$component
AtomlistAtom<-dentree$AtomlistAtom
AtomlistNext<-dentree$AtomlistNext

# Tama koodi on jo kergrid:ssa, lasketaan volume of one atom
d<-length(N)
minim<-matrix(0,d,1)  #minim is d-vector of minimums
maxim<-matrix(0,d,1)
for (i in 1:d){
  minim[i]<-min(dendat[,i])
  maxim[i]<-max(dendat[,i])
}
delta<-(maxim-minim+2*h)/(N+1)  
volofatom<-prod(delta)

#if (cfre) nodefrek<-cfrekvdya(seplsets,binfrek) else nodefrek<-NULL 

if (ccen==TRUE) cvol<-TRUE
if (cvol){
  volume<-cvolumdya(volofatom,component,AtomlistNext)
  kerroin<-cinte(invalue,volume,parent) 
  sepvalnor<-invalue/kerroin
} 
else{  
  volume<-NULL
  sepvalnor<-NULL
}

if (ccen && cvol){
  index<-kg$index
  d<-dim(dendat)[2]
  center<-ccentedya(volofatom,component,AtomlistNext,AtomlistAtom,
                    volume,minim,h,delta,index,d)
  }
  else{
      center<-NULL
  }

return(list(parent=parent,level=sepvalnor,invalue=invalue,
volume=volume,center=center))#,nodefrek=nodefrek))
#values: normeeratut arvot
#invalues: alkuperaiset frekvenssit/arvot 
#nodefrek: kunkin solmun frekvenssi
}








proftree<-function(tr,
Q=NULL,frekv=NULL,cvol=TRUE,ccen=TRUE,cfre=FALSE)
{

d<-dim(tr$upp)[2]

if (tr$left[1]==0){
  parent=c(0)
  sepvalnor=c(tr$mean[1])
  invalue=c(tr$mean[1])
  volume=c(tr$volume[1])
  rec<-matrix(0,2*d,1)
  for (j in 1:d){
     rec[2*j-1]<-tr$suppo[2*j-1]+tr$low[1,j]*tr$step[j]
     rec[2*j]<-  tr$suppo[2*j-1]+tr$upp[1,j]*tr$step[j]
  }
  center=t(cenone(rec))
}

else{

nodenumOfTree<-length(tr$left)

# make parent
parent<-makeparent(tr$left,tr$right)

mi<-makeinfo(tr$left,tr$right,tr$mean,tr$low,tr$upp)
#infopointer<-mi$infopointer
#terminalnum<-mi$terminalnum
#low<-mi$low
#upp<-mi$upp
#nodefinder<-mi$nodefinder
#value<-mi$value

{
if (!is.null(Q)){
   maxval<-max(mi$value)
   minval<-min(mi$value)
   step<-(maxval-minval)/Q
   levseq<-seq(from=minval,to=maxval-step,by=step)
}
else{
   eppsi<-0        #0.0000001
   levseq<-matrix(0,length(mi$value),1)
   ordu<-order(mi$value)
   ru<-1
   laskuri<-1
   car<-ordu[ru]
   levseq[laskuri]<-mi$value[car]-eppsi
   while (ru < length(mi$value)){
       carnew<-ordu[ru+1]
       if (mi$value[carnew]>mi$value[car]){
          laskuri<-laskuri+1
          levseq[laskuri]<-mi$value[carnew]-eppsi
      }
      ru<-ru+1
   }
   levseq<-levseq[1:laskuri]
   Q<-laskuri
}
}

levfrekv<-matrix(0,Q,1)
atomnum<-length(mi$value)   #=mi$terminalnum
for (i in 1:atomnum){
   for (j in 1:Q){
      if (mi$value[i]>=levseq[j]){
         levfrekv[j]<-levfrekv[j]+1
      }
   }
}
numofall<-sum(levfrekv)

inlevseq<-matrix(0,Q+1,1)
inlevseq[2:(Q+1)]<-levseq
insuppo<-matrix(0,2*d+1,1)
insuppo[2:(2*d+1)]<-tr$suppo
instep<-matrix(0,d+1,1)
sc<-matrix(0,d,1)
for (i in 1:d){
    step[i]<-(tr$support[2*i]-tr$support[2*i-1])/tr$N[i]
}
instep[2:(d+1)]<-sc    #stepcalc(tr$support,tr$N)    #tr$step
inleft<-matrix(0,nodenumOfTree+1,1)
inleft[2:(nodenumOfTree+1)]<-tr$left
inright<-matrix(0,nodenumOfTree+1,1)
inright[2:(nodenumOfTree+1)]<-tr$right
inparent<-matrix(0,nodenumOfTree+1,1)
inparent[2:(nodenumOfTree+1)]<-parent
inval<-matrix(0,nodenumOfTree+1,1)
inval[2:(nodenumOfTree+1)]<-tr$mean  #tr$val
invec<-matrix(0,nodenumOfTree+1,1)
invec[2:(nodenumOfTree+1)]<-tr$direc

for (i in 1:(nodenumOfTree+1)){
  if (is.na(inval[i])){
       inval[i]<-0
       invec[i]<-0
  }
}

ininfopointer<-matrix(0,nodenumOfTree+1,1)
ininfopointer[2:(nodenumOfTree+1)]<-mi$infopointer

invalue<-matrix(0,atomnum+1,1)
invalue[2:(atomnum+1)]<-mi$value
inlow<-matrix(0,atomnum*d+1,1)
inupp<-matrix(0,atomnum*d+1,1)
for (i in 1:atomnum){
   for (j in 1:d){
       inlow[1+(i-1)*d+j]=mi$low[i,j]
       inupp[1+(i-1)*d+j]=mi$upp[i,j]
   }
}
innodefinder<-matrix(0,atomnum+1,1)
innodefinder[2:(atomnum+1)]<-mi$nodefinder

inlowtr<-matrix(0,nodenumOfTree*d+1,1)
inupptr<-matrix(0,nodenumOfTree*d+1,1)
for (i in 1:nodenumOfTree){
   for (j in 1:d){
       inlowtr[1+(i-1)*d+j]=tr$low[i,j]
       inupptr[1+(i-1)*d+j]=tr$upp[i,j]
   }
}

# we have tree with "nodenumOfTree" nodes
# we hae assocoated info with "atomnum" elements => info for each leaf
#   that is, atomnum = number of leaves

dentree<-.C("proftreeC",
               as.integer(numofall),
               as.integer(atomnum),
               as.double(inlevseq),
               as.integer(d),
               as.integer(Q),
               as.double(instep),
               as.double(insuppo), 
               as.integer(nodenumOfTree),
               as.integer(inleft),
               as.integer(inright),
               as.integer(inparent),
               as.integer(inval),
               as.integer(invec),
               as.integer(ininfopointer),
               as.integer(inlowtr),
               as.integer(inupptr),
               as.double(invalue),
               as.integer(inlow),
               as.integer(inupp),
               as.integer(innodefinder),
               level = double(numofall+1),
               parent = integer(numofall+1),
               volume = double(numofall+1),
               center = double(d*numofall+1),
               efek = integer(1),
PACKAGE="denpro")
               #component = integer(numofall+1),
               #AtomlistAtomOut = integer(numofall+1),
               #AtomlistNextOut = integer(numofall+1),
               #numOfAtoms = integer(1))

#               lapu = double(numofall+1))

efek<-dentree$efek
numOfAtoms<-dentree$numOfAtoms
invalue<-dentree$level[2:(efek+1)]
parent<-dentree$parent[2:(efek+1)]
#component<-dentree$component[2:(efek+1)]
#AtomlistAtom<-dentree$AtomlistAtom[2:(numOfAtoms+1)]
#AtomlistNext<-dentree$AtomlistNext[2:(numOfAtoms+1)]

#if (cfre) nodefrek<-cfrekvdya(seplsets,binfrek) else nodefrek<-NULL 
if (ccen==TRUE) cvol<-TRUE
if (cvol){
#  volume<-cvolumbag(component=component,AtomlistAtom=AtomlistAtom,AtomlistNext=AtomlistNext,low=tr$low,upp=tr$upp,steppi=tr$step)
   volume<-dentree$volume[2:(efek+1)]
#  kerroin<-cinte(invalue,volume,parent) 
#  sepvalnor<-invalue/kerroin
   sepvalnor<-invalue
} 
else{  
  volume<-NULL
  sepvalnor<-NULL
}

if (ccen && cvol){
  #center<-ccentebag(component,AtomlistAtom,AtomlistNext,tr$low,tr$upp,volume,
  #                  tr$step,tr$suppo)
  outcenter<-dentree$center[2:(d*efek+1)]
  center<-matrix(0,efek,d)
  for (i in 1:efek){
     for (j in 1:d){
        center[i,j]<-outcenter[(i-1)*d+j]
     }
  }
  }
  else{
      center<-NULL
  }


} #else (tr$left[1]>0)


return(list(parent=parent,level=sepvalnor,invalue=invalue,
volume=volume,center=t(center)))    #nodefrek=nodefrek))
#values: normeeratut arvot
#invalues: alkuperaiset frekvenssit/arvot 
#nodefrek: kunkin solmun frekvenssi
}










proftreeR<-function(tr,
Q=NULL,frekv=NULL,cvol=TRUE,ccen=TRUE,cfre=FALSE)
{
#set.seed(seed=1)
#dendat<-matrix(rnorm(20),10)
#h<-1 
#N<-c(4,4)
#Q<-3

d<-dim(tr$upp)[2]

nodenumOfTree<-length(tr$left)

low<-tr$low
upp<-tr$upp
val<-tr$val
#low<-matrix(0,nodenumOfTree,d)
#upp<-matrix(0,nodenumOfTree,d)
#val<-matrix(NA,nodenumOfTree,1)
#for (i in 1:nodenumOfTree){
#  dimu<-tr$vec[i]
#  if (!is.na(dimu) && (dimu>0)) 
#       val[i]<-tr$suppo[2*dimu-1]+tr$val[i]*tr$step[dimu]
#  for (j in 1:d){
#      low[i,j]<-tr$suppo[2*j-1]+tr$low[i,j]*tr$step[j]
#      upp[i,j]<-tr$suppo[2*j-1]+tr$upp[i,j]*tr$step[j]
#  }
#}

# make parent
parent<-matrix(0,length(tr$left),1)
node<-1
while (node<=length(tr$left)){
   if ((!is.na(tr$left[node])) && (tr$left[node]!=0)){
        parent[tr$left[node]]<-node
   }
   if ((!is.na(tr$right[node])) && (tr$left[node]!=0)){
        parent[tr$right[node]]<-node
   }
   node<-node+1
}

mi<-makeinfo(tr$left,tr$right,tr$mean,low,upp)
infopointer<-mi$infopointer
terminalnum<-mi$terminalnum
low<-mi$low
upp<-mi$upp
nodefinder<-mi$nodefinder
value<-mi$value

{
if (!is.null(Q)){
   maxval<-max(value)
   minval<-min(value)
   step<-(maxval-minval)/Q
   levseq<-seq(from=minval,to=maxval-step,by=step)
}
else{
   eppsi<-0        #0.0000001
   levseq<-matrix(0,length(value),1)
   ordu<-order(value)
   ru<-1
   #car<-ordu[ru]
   #while ((ru <= length(value)) && (value[car]==0)){
   #     ru<-ru+1
   #     car<-ordu[ru]
   #}  # we have found first non zero
   laskuri<-1
   car<-ordu[ru]
   levseq[laskuri]<-value[car]-eppsi
   while (ru < length(value)){
       carnew<-ordu[ru+1]
       if (value[carnew]>value[car]){
          laskuri<-laskuri+1
          levseq[laskuri]<-value[carnew]-eppsi
      }
      ru<-ru+1
   }
   levseq<-levseq[1:laskuri]
   Q<-laskuri
}
}

levfrekv<-matrix(0,Q,1)
atomnum<-length(value)
for (i in 1:atomnum){
   for (j in 1:Q){
      if (value[i]>=levseq[j]){
         levfrekv[j]<-levfrekv[j]+1
      }
   }
}
numofall<-sum(levfrekv)

dentree<-decombag(numofall,levseq,
tr$left,tr$right,val,tr$vec,infopointer,parent,
nodenumOfTree,terminalnum,
value,low,upp,nodefinder,
d)

invalue<-dentree$level
parent<-dentree$parent
component<-dentree$component
AtomlistAtom<-dentree$AtomlistAtom
AtomlistNext<-dentree$AtomlistNext

#if (cfre) nodefrek<-cfrekvdya(seplsets,binfrek) else nodefrek<-NULL 

if (ccen==TRUE) cvol<-TRUE
if (cvol){
  volume<-cvolumbag(component,AtomlistAtom,AtomlistNext,tr$low,tr$upp,
                    steppi=tr$step)
  kerroin<-cinte(invalue,volume,parent) 
  sepvalnor<-invalue/kerroin
} 
else{  
  volume<-NULL
  sepvalnor<-NULL
}

if (ccen && cvol){
  center<-ccentebag(component,AtomlistAtom,AtomlistNext,tr$low,tr$upp,volume,
                    tr$step,tr$suppo)
  }
  else{
      center<-NULL
  }

return(list(parent=parent,level=sepvalnor,invalue=invalue,
volume=volume,center=center))    #nodefrek=nodefrek))
#values: normeeratut arvot
#invalues: alkuperaiset frekvenssit/arvot 
#nodefrek: kunkin solmun frekvenssi
}









prunemodes<-function(lst,modenum=1,num=NULL,exmalim=NULL,maxnum=NULL)
{
# prunes from a level set tree "lst" the modes with "num" 
# smallest excess masses 
# or the modes with smaller excess mass than "exmalim"

if (is.null(num)){
    curmodenum<-moodilkm(lst$parent)$lkm
    num<-curmodenum-modenum
}

go.on<-TRUE
nn<-1
while (go.on){

  len<-length(lst$parent)
  child.frekve<-matrix(0,len,1)
  for (i in 1:len){
     if (lst$parent[i]>0) 
     child.frekve[lst$parent[i]]<-child.frekve[lst$parent[i]]+1
  }

  ml<-moodilkm(lst$parent)
  mode.list<-ml$modloc
  roots.of.modes<-matrix(0,length(mode.list),1)
  for (aa in 1:length(mode.list)){
      node<-mode.list[aa]
      while ((lst$parent[node]>0) && (child.frekve[lst$parent[node]]==1)){ 
          node<-lst$parent[node]
      }
      roots.of.modes[aa]<-node
  }

  em<-excmas(lst)
  or<-order(em[roots.of.modes])
  smallest<-ml$modloc[or[1]]
  if (nn==1) exma.of.modes<-em[roots.of.modes]

  node<-smallest
  emsmallest<-em[node]

  if ((is.null(exmalim)) || ((!is.null(exmalim)) && (emsmallest<=exmalim))){

     rem.list<-c(node)
     while ((lst$parent[node]>0) && (child.frekve[lst$parent[node]]==1)){ 
           node<-lst$parent[node]
           rem.list<-c(rem.list,node)
     }

     for (kk in 1:length(rem.list)){
        remo<-rem.list[kk]
        for (ll in 1:length(lst$parent)){
            if (lst$parent[ll]>remo) lst$parent[ll]<-lst$parent[ll]-1
        }
        lst$parent<-lst$parent[-remo]
     }
     lst$level<-lst$level[-rem.list]
     lst$volume<-lst$volume[-rem.list]
     lst$center<-lst$center[,-rem.list]
     lst$distcenter<-lst$distcenter[,-rem.list]
     lst$proba<-lst$proba[-rem.list]
     lst$infopointer<-lst$infopointer[-rem.list]
  }
  else if ((!is.null(exmalim)) && (emsmallest>exmalim)) go.on<-FALSE

  nn<-nn+1
  if ((nn>num) && (is.null(exmalim))) go.on<-FALSE
  if ((!is.null(maxnum)) && (nn>maxnum)) go.on<-FALSE 
}

lst$exma.of.modes<-exma.of.modes

return(lst=lst)
}


pruneprof<-function(mt){
#prunes profile so that only root and nodes with siblings are left
#
#mt is a result from multitree
#
roots<-mt$roots
child<-mt$child
sibling<-mt$sibling
siborder<-mt$siborder
#
itemnum<-length(child)
newchild<-matrix(0,itemnum,1)
#
rootnum<-length(roots)
#
for (i in 1:rootnum){
    pino<-matrix(0,itemnum,1)
    pino[1]<-roots[i]  
    pinin<-1
    while (pinin>0){
        cur<-pino[pinin]      #take from stack
        pinin<-pinin-1
        if (sibling[cur]>0){
              pinin<-pinin+1
              pino[pinin]<-sibling[cur]
        }
        while (child[cur]>0){    #go to left and put right nodes to stack
             candi<-child[cur]
             while ((child[candi]>0) && (sibling[candi]==0)){
                 candi<-child[candi]
             }
             if (sibling[candi]>0){  #if candi has siblings
                newchild[cur]<-candi
                pinin<-pinin+1
                pino[pinin]<-sibling[candi]
             } 
             cur<-candi
        }
    }
}
return(list(roots=roots,child=newchild,sibling=sibling,siborder=siborder))
}







qq.plot<-function(dendat=NULL,compa="gauss",basis="gauss",
mean=0,sig=1,df=1,
gnum=1000,d=1,R=3,qqtype="1d",cex.lab=1,cex.axis=1,col="blue",lwd=1)
{
if (qqtype=="1d"){
   n<-length(dendat) #dim(dendat)[1]
   p<-(seq(1:n)-1/2)/n
   if (compa=="gauss") x<-qnorm(p,mean=mean,sd=sig)
   if (compa=="student") x<-sig*qt(p,df=df)+mean
   if (compa=="unif") x<-sig*qunif(p)+mean
   if (compa=="exp") x<-sig*qexp(p)+mean
   if (compa=="doubleexp"){
       alku<-which(p<0.5)
       loppu<-which(p>=0.5)
       x[alku]<--sig*qexp(1-2*p[alku])+mean
       x[loppu]<-sig*qexp(2*p[loppu]-1)+mean
   }
   y<-dendat[order(dendat)]
   tyyppi<-"p"
   xlab<-"compared quantiles"
   ylab<-"empirical quantiles"
}
if (qqtype=="lower"){
   n<-length(dendat) #dim(dendat)[1]
   p<-(seq(1:n)-1/2)/n
   if (compa=="gauss") x<-qnorm(p/2,mean=mean,sd=sig)
   if (compa=="student") x<-sig*qt(p/2,df=df)+mean
   if (compa=="unif") x<-sig*qunif(p/2)+mean
   if (compa=="exp") x<-sig*qexp(p/2)+mean
   y<-dendat[order(dendat)]
   tyyppi<-"p"
   xlab<-"compared quantiles"
   ylab<-"empirical quantiles"
}
if (qqtype=="p2v"){
     rp<-tailfunc(R,d,type=compa,gnum=gnum,sig=sig,nu=df)
     x<-rp$volu
     rp2<-tailfunc(R,d,type=basis,gnum=gnum,sig=sig,nu=df)
     y<-rp2$volu
     tyyppi="l"
     ylab<-"empirical"
     xlab<-"model"
}

plot(x,y,type=tyyppi,ylab=ylab,xlab=xlab,cex.lab=cex.lab,cex.axis=cex.axis)
maxxy<-max(max(x),max(y))
minxy<-min(min(x),min(y))
segments(minxy,minxy,maxxy,maxxy,col=col,lwd=lwd)
}





quanti<-function(values,lkm,base){
#Quantises a vecor of values
#
#values is len-vector
#lkm is positive integer
#base>0
#
#returns len-vector
#
ma<-max(values)
askel<-ma/(lkm-1)
len<-length(values)
ans<-matrix(0,len,1)
for (i in 1:len){
  inv<-base^(values[i]*log(ma+1,base)/ma)-1
  ind<-round(inv/askel)+1
  diskr<-ma*seq(0,lkm-1,1)/(lkm-1)
  disinv<-diskr[ind]
  ans[i]<-ma*log(disinv+1,base)/log(ma+1,base)
}
return(ans)
}
rotation<-function(t,d=2,basis=FALSE)
{

if (d==2){

  rota<-matrix(0,2,2)
  rota[1,1]<-cos(t)
  rota[1,2]<-sin(t)
  rota[2,1]<--sin(t)
  rota[2,2]<-cos(t)

}

if ((d==2) && (basis)){

  rota<-matrix(0,2,2)
  basis1<-c(1,1)
  basis2<-c(-1,1)
  basis1<-basis1/sqrt(sum(basis1^2))
  basis2<-basis2/sqrt(sum(basis2^2))
  rota[,1]<-basis1
  rota[,2]<-basis2

}

if (d==4){

  rotxy<-matrix(0,4,4)
  for (i in 1:4) rotxy[i,i]<-1
  rotxy[1,1]<-cos(t)
  rotxy[1,2]<-sin(t)
  rotxy[2,1]<--sin(t)
  rotxy[2,2]<-cos(t)

  rotyz<-matrix(0,4,4)
  for (i in 1:4) rotyz[i,i]<-1
  rotyz[2,2]<-cos(t)
  rotyz[2,3]<-sin(t) 
  rotyz[3,2]<--sin(t)
  rotyz[3,3]<-cos(t)

  rotzx<-matrix(0,4,4)
  for (i in 1:4) rotzx[i,i]<-1
  rotzx[1,1]<-cos(t)
  rotzx[1,3]<--sin(t)
  rotzx[3,1]<-sin(t)
  rotzx[3,3]<-cos(t)

  rotxw<-matrix(0,4,4)
  for (i in 1:4) rotxw[i,i]<-1
  rotxw[1,1]<-cos(t)
  rotxw[1,4]<-sin(t)
  rotxw[4,1]<--sin(t)
  rotxw[4,4]<-cos(t)

  rotyw<-matrix(0,4,4)
  for (i in 1:4) rotyw[i,i]<-1
  rotyw[2,2]<-cos(t)
  rotyw[2,4]<--sin(t)
  rotyw[4,2]<-sin(t)
  rotyw[4,4]<-cos(t)

  rotzw<-matrix(0,4,4)
  for (i in 1:4) rotzw[i,i]<-1
  rotzw[3,3]<-cos(t)
  rotzw[2,4]<--sin(t)
  rotzw[4,3]<-sin(t)
  rotzw[4,4]<-cos(t)

  rota<-rotxy%*%rotyz%*%rotzx%*%rotxw%*%rotyw%*%rotzw

}

return(rota)
}

scaletable<-function(estiseq,paletti=NULL,shift=0,ptext=0,ptextst=0,
bm=NULL,#mt=NULL,
levnum=60,levnumst=60,redu=TRUE,
volu.modelabel=TRUE,volu.colo=TRUE,st.modelabel=FALSE,st.colo=TRUE
)
{
# preparation
if ((length(estiseq$hseq)>1) && (estiseq$hseq[1]<estiseq$hseq[2])){  
    hnum<-length(estiseq$hseq)
    estiseq$hseq<-estiseq$hseq[seq(hnum,1)]
    apuseq<-list(estiseq$lstseq[[hnum]])
    i<-2
    while (i <= hnum){
         apuseq<-c(apuseq,list(estiseq$lstseq[[hnum-i+1]]))
         i<-i+1 
   }
   estiseq$lstseq<-apuseq
}

if (estiseq$type=="carthisto")  smootseq<--estiseq$leaf
else if (estiseq$type=="greedy") smootseq<--estiseq$hseq
else if (estiseq$type=="bagghisto") smootseq<--estiseq$hseq
else smootseq<-estiseq$hseq
hnum<-length(smootseq)
d<-dim(estiseq$lstseq[[hnum]]$center)[1]

if (estiseq$type=="carthisto") redu<-FALSE
if (is.null(estiseq$stseq)) levnumst<-NULL

if (is.null(paletti))
paletti<-c("red","blue","green","turquoise","orange","navy",
"darkgreen","orchid",colors()[50:100])

# prune the level set trees
if ((!is.null(levnum)) && (redu)){
   for (i in 1:hnum){
      lf<-treedisc(estiseq$lstseq[[i]],estiseq$pcfseq[[i]],levnum) 
      if (i==1){
           if (hnum==1){
               reduseq<-lf
           }
           else{
               reduseq<-list(lf)
           }
      }
      else{
          reduseq<-c(reduseq,list(lf))
      }
  }
  estiseq$lstseq<-reduseq
}

# prune the shape trees
if ((!is.null(levnumst)) && (redu)){
   for (i in 1:hnum){
      lf<-treedisc(estiseq$stseq[[i]],estiseq$pcfseq[[i]],levnumst) 
      if (i==1){
           if (hnum==1){
               reduseq<-lf
           }
           else{
               reduseq<-list(lf)
           }
      }
      else{
          reduseq<-c(reduseq,list(lf))
      }
  }
}
else reduseq<-estiseq$stseq

#if (is.null(mt)) 
mt<-modegraph(estiseq)
if (is.null(bm)) bm<-branchmap(estiseq)

####################################
devicontrol<-2
devibranch<-3
devibary<-4
devimodet<-5
devivolu<-6
deviradi<-7
deviloca<-8

xmin<--0.5
xmax<-0.5
ymin<--1
ymax<-1
lkm<-7
step<-(ymax-ymin)/(lkm-1)
heig<-seq(ymin,ymax,step)
xloc<-0

# control window
x11(width=2,height=6)
plot(x="",y="",xlab="",ylab="",xaxt="n",yaxt="n",
xlim=c(xmin,xmax),ylim=c(ymin,ymax))
text(xloc,heig[lkm],"I")      #"Mode graph")
text(xloc,heig[lkm-1],"II")   #"Map of branches")
text(xloc,heig[lkm-2],"III")  #"Volume plot")
text(xloc,heig[lkm-3],"IV")   #"Barycenter plot")
text(xloc,heig[lkm-4],"V")    #"Radius plot")
text(xloc,heig[lkm-5],"VI")   #"Location plot")
text(xloc,heig[lkm-6],"STOP")

devit<-matrix(0,lkm,1)
devit[1]<-devimodet
devit[2]<-devibranch
devit[3]<-devivolu
devit[4]<-devibary
devit[5]<-deviradi
devit[6]<-deviloca
devit[7]<-devicontrol

# choose estimate
indeksi<-1
pr<-estiseq$lstseq[[indeksi]]
pcf<-estiseq$pcfseq[[indeksi]]
if (!is.null(levnumst)){ 
      st<-estiseq$stseq[[indeksi]]
      stredu<-reduseq[[indeksi]]
}
hcur<-estiseq$hseq[indeksi]

# branch map
x11(width=4,height=5)
phi<-40
theta<-10
persp(x=bm$level,y=bm$h,z=bm$z, xlab="level",ylab="h",zlab="",
ticktype="detailed",col=bm$col,phi=phi,theta=theta)
title(main="II Map of branches")

# barycenter plot
x11(width=3.5,height=4)
coordi<-1
icolo<-mt$colot[mt$low[1]:mt$upp[1]]
inodes<-mt$nodepointer[mt$low[1]:mt$upp[1]]
modlab<-plotbary(pr,coordi=coordi,ptext=ptext,
        modlabret=TRUE,modecolo=icolo,modepointer=inodes)
title(main="IV Barycenter plot",
      sub=paste("coordinate",as.character(coordi)))

# mode tree
x11(width=4,height=5)
coordi<-1
plotmodet(mt,coordi=coordi)
modelocx<-modlab$modelocat[,coordi]+shift
modelocy<-smootseq[1]
labels<-modlab$labels
text(modelocx,modelocy,labels)
title(main="I Mode graph",sub=paste("coordinate",as.character(coordi)))

# volume plot
x11(width=3.5,height=4)
icolo<-mt$colot[mt$low[1]:mt$upp[1]]
inodes<-mt$nodepointer[mt$low[1]:mt$upp[1]]
plotvolu(pr,ptext=ptext,modelabel=volu.modelabel,colo=volu.colo,
         modecolo=icolo,modepointer=inodes)
title(main="III Volume plot",
      sub=paste("h=",as.character(round(hcur,digits=3))))

# radius plot
if (!is.null(levnumst)){
  refelab<-"moodi"
  st.moodi<-st

  lev<-0.1*max(pcf$value)  
  refe<-st$bary
  st.bary<-leafsfirst(pcf,lev=lev,refe=refe)

  x11(width=3,height=4)
  plotvolu(stredu,ptext=ptextst,symbo="T",
           modelabel=st.modelabel,colo=st.colo)
  title(main="V Radius plot",
        sub=paste("level=",as.character(round(lev,digits=3)),
        ", ref.point=mode"))
}

# location plot
if (!is.null(levnumst)){
  x11(width=3,height=4)
  lcoordi<-1
  plotbary(stredu,coordi=lcoordi,ptext=ptextst,symbo="T")
  title(main="VI Location plot",
        sub=paste("coordinate",as.character(lcoordi)))
}


##################################################################
ylow<-matrix(0,lkm,1)
yupp<-matrix(0,lkm,1)
for (i in 1:lkm){
    ylow[i]<-heig[i]-step/2
    yupp[i]<-heig[i]+step/2
}
ylow<-ylow[lkm:1]
yupp<-yupp[lkm:1]

dev.set(which = devicontrol)
loc<-locator(1)
while (loc$y>=yupp[lkm]){
  for (i in 1:lkm){
      if ((loc$y>ylow[i]) && (loc$y<=yupp[i])){
                 devi<-devit[i]
      }
  }
  dev.set(which = devi)
  loc<-locator(1)

  # interaction in modegraph
  if (devi==devimodet){
       alaraja<-smootseq[length(smootseq)]
       while (loc$y>=alaraja){
          coordi<-1
          ylamodet<-smootseq[1]
          while (loc$y>=ylamodet){
              if (coordi<=(d-1)) coordi<-coordi+1 else coordi<-1
              plotmodet(mt,coordi=coordi)
              modelocx<-modlab$modelocat[,coordi]+shift
              modelocy<-smootseq[indeksi]
              labels<-modlab$labels
              text(modelocx,modelocy,labels)
              title(main="I Mode graph",
                    sub=paste("coordinate",as.character(coordi)))

              loc<-locator(1)
          }
          
          if (loc$y>=alaraja){
             alamidi<-(smootseq[1]+smootseq[1+1])/2
             if (loc$y>=alamidi) indeksi<-1
             for (i in 2:(hnum-1)){
                alamidi<-(smootseq[i]+smootseq[i+1])/2
                ylamidi<-(smootseq[i-1]+smootseq[i])/2

                if ((loc$y>=alamidi) && (loc$y<ylamidi)) indeksi<-i
             }
             ylamidi<-(smootseq[hnum-1]+smootseq[hnum])/2
             if (loc$y<ylamidi) indeksi<-hnum

             pr<-estiseq$lstseq[[indeksi]]
             pcf<-estiseq$pcfseq[[indeksi]]
             hcur<-estiseq$hseq[[indeksi]]
             if (!is.null(levnumst)){ 
                    lev<-0.1*max(pcf$value)
                    st<-estiseq$stseq[[indeksi]]
                    st.moodi<-st
                    st.bary<-NULL
                    stredu<-reduseq[[indeksi]]
             }

             dev.set(which = devivolu)
             icolo<-mt$colot[mt$low[indeksi]:mt$upp[indeksi]]
             inodes<-mt$nodepointer[mt$low[indeksi]:mt$upp[indeksi]] 
             plotvolu(pr,ptext=ptext,modelabel=volu.modelabel,colo=volu.colo,
                      modecolo=icolo,modepointer=inodes)
             title(main="III Volume plot",
                   sub=paste("h=",as.character(round(hcur,digits=3))))
  
             dev.set(which = devibary) 
             coordi<-1
             modlab<-plotbary(pr,coordi=coordi,ptext=ptext,
                              modlabret=T,modecolo=icolo,modepointer=inodes)
             title(main="IV Barycenter plot",
                   sub=paste("coordinate",as.character(coordi)))

             dev.set(which = deviradi) 
             plotvolu(stredu,ptext=ptextst,symbo="T",
                      modelabel=st.modelabel,colo=st.colo)
             title(main="V Radius plot",
                   sub=paste("level=",as.character(round(lev,digits=3)),
                             ", ref.point=mode"))
 
             dev.set(which = deviloca) 
             lcoordi<-1
             plotbary(stredu,coordi=lcoordi,ptext=ptextst,symbo="T")
             title(main="VI Location plot",
                   sub=paste("coordinate",as.character(lcoordi)))
             
             dev.set(which = devimodet)

             modelocx<-modlab$modelocat[,coordi]+shift
             modelocy<-smootseq[indeksi]
             labels<-modlab$labels
             text(modelocx,modelocy,labels)

             loc<-locator(1)
          }
       }
       #dev.set(which = devicontrol)
  }

  # interaction in volume plot
  if (devi==devivolu){
     alaasso<-0
     ylaasso<-max(pr$level)
     alax<-0
     ylax<-pr$volume[1]
     while (loc$y>=alaasso){
        if (loc$x>=0){
           if (loc$y>ylaasso) plotvolu(pr)
           else if (loc$x>0){
              keskip<-alax+(ylax-alax)/2
              if (loc$x >= keskip) ylax<-loc$x
              else                 alax<-loc$x
              icolo<-mt$colot[mt$low[indeksi]:mt$upp[indeksi]]
              inodes<-mt$nodepointer[mt$low[indeksi]:mt$upp[indeksi]] 
              plotvolu(pr,xlim=c(alax,ylax),ptext=ptext,
                       modelabel=volu.modelabel,colo=volu.colo,
                       modecolo=icolo,modepointer=inodes)
           }
           title(main="III Volume plot",
                 sub=paste("h=",as.character(round(hcur,digits=3))))
        }     
        else if (!is.null(levnumst)){
             maksi<-max(pr$level)
             mode<-locofmax(pcf)
             lev<-min(max(0,loc$y),maksi)
             st<-leafsfirst(pcf,refe=mode,lev=lev)
             st.moodi<-st
             st.bary<-NULL
             if (redu) stredu<-treedisc(st,pcf,ngrid=levnumst) else stredu<-st
             refelab<-"moodi"

             dev.set(which = deviradi) 
             plotvolu(stredu,ptext=ptextst,symbo="T",
                      modelabel=st.modelabel,colo=st.colo)
             title(main="V Radius plot",
                   sub=paste("level=",as.character(round(lev,digits=3)),
                             ", ref.point=mode"))

             dev.set(which = deviloca) 
             lcoordi<-1
             plotbary(stredu,coordi=lcoordi,ptext=ptextst,symbo="T")
             title(main="VI Location plot",
                   sub=paste("coordinate",as.character(lcoordi)))

             dev.set(which = devivolu)       
        }
        loc<-locator(1)
     }
  }

  # interaction in barycenter plot
  if (devi==devibary){
      coordi<-1
      icolo<-mt$colot[mt$low[indeksi]:mt$upp[indeksi]]
      inodes<-mt$nodepointer[mt$low[indeksi]:mt$upp[indeksi]]
      modlab<-plotbary(pr,coordi=coordi,ptext=ptext,
                       modlabret=T,modecolo=icolo,modepointer=inodes)
      title(sub=paste("barycenter plot, coordinate",as.character(coordi)))
      alaasso<-0
      while (loc$y>=alaasso){
         if (coordi<=(d-1)) coordi<-coordi+1 else coordi<-1
         plotbary(pr,coordi=coordi,ptext=ptext,modecolo=icolo,
                  modepointer=inodes,modelabel=TRUE)
         title(main="IV Barycenter plot",
               sub=paste("coordinate",as.character(coordi)))

         loc<-locator(1)
      }
  }

  # interaction in radius plot
  if (devi==deviradi){
       alaraja<-0
       while (loc$y>=alaraja){

          ylaraja<-max(st$level)
          if (loc$y>=ylaraja){
              if (refelab=="moodi"){ 
                   refelab<-"bary"
                   if (is.null(st.bary)){  
                       refe<-st$bary
                       st.bary<-leafsfirst(pcf,lev=lev,refe=refe)
                   }
                   st<-st.bary
              }
              else{ 
                   refelab<-"moodi"
                   st<-st.moodi
              }
              if (redu) stredu<-treedisc(st,pcf,ngrid=levnumst) else stredu<-st
              plotvolu(stredu,ptext=ptextst,symbo="T",
                       modelabel=st.modelabel,colo=st.colo)
              if (refelab=="moodi") 
                 title(main="V Radius plot",
                       sub=paste("level=",as.character(round(lev,digits=3)),
                       ",  mode=refe'nce point"))
              else 
                 title(main="V Radius plot",
                       sub=paste("level=",as.character(round(lev,digits=3)),
                       ", ref.point= barycenter"))

              dev.set(which = deviloca) 
              lcoordi<-1
              plotbary(stredu,coordi=lcoordi,ptext=ptextst,symbo="T")
              title(main="VI Location plot",
                    sub=paste("coordinate",as.character(lcoordi)))

              dev.set(which = deviradi)      
              loc<-locator(1)
          }
          else{
              sarmilkm<-moodilkm(stredu$parent)$lkm
              streduredu<-stredu
              while ((loc$y<ylaraja) && (loc$y>alaraja)){
                   cursarmilkm<-moodilkm(streduredu$parent)$lkm
                   if (cursarmilkm>=2) newsarmilkm<-cursarmilkm-1 
                   else newsarmilkm<-sarmilkm 
                   streduredu<-prunemodes(stredu,modenum=newsarmilkm)
                   plotvolu(streduredu,ptext=ptextst,symbo="T",
                            modelabel=st.modelabel,colo=st.colo)
                   if (refelab=="moodi") 
                         title(main="V Radius plot",
                         sub=paste("level=",as.character(round(lev,digits=3)),
                         ",  mode=refe'nce point"))
                   else 
                       title(main="V Radius plot",
                       sub=paste("level=",as.character(round(lev,digits=3)),
                       ", ref.point=barycenter"))

                   dev.set(which = deviloca) 
                   lcoordi<-1
                   plotbary(streduredu,coordi=lcoordi,ptext=ptextst,symbo="T")
                   title(main="VI Location plot",
                         sub=paste("coordinate",as.character(lcoordi)))
 
                   dev.set(which = deviradi)      
                   loc<-locator(1)
              }
          }
          loc<-locator(1)
      }
  }

  # interaction in location plot
  if (devi==deviloca){
      coordi<-1
      plotbary(stredu,coordi=coordi,ptext=ptextst,symbo="T")
      title(main="VI Location plot",
            sub=paste("coordinate",as.character(coordi)))
      alaasso<-0
      while (loc$y>=alaasso){
         if (coordi<=(d-1)) coordi<-coordi+1 else coordi<-1
         plotbary(stredu,coordi=coordi,ptext=ptextst,symbo="T")
         title(main="VI Location plot",
               sub=paste("coordinate",as.character(coordi)))

         loc<-locator(1)
      }
  }

  # interaction in branching map
  if (devi==devibranch){
      alaraja<--0.4
      while (loc$y>=alaraja){

          if (loc$x>=0) theta<-theta+10 else theta<-theta-10
          if (loc$y>=0) phi<-phi+10 else phi<-phi-10

          persp(x=bm$level,y=bm$h,z=bm$z,col=bm$col,
          xlab="level",ylab="h",zlab="",ticktype="detailed",
          phi=phi,theta=theta)
          title(main="II Map of branches")

         loc<-locator(1)
      }
  }

  # end
  dev.set(which = devicontrol)
  loc<-locator(1)
}

if (!is.null(levnumst)) devlkm<-lkm
else devlkm<-lkm-2
for (i in 1:devlkm) dev.off()

}



shape2d<-function(shtseq, gnum=500, type="radius", type2="slice", 
gnum2=1000, ngrid=30, norma=FALSE, xmax=10, modelim=2, exmalim=NULL,
maxnum=NULL)
{
# type "proba"    type2 "boundary"
lkm<-length(shtseq$level)
d<-length(shtseq$pcf$N)

if (type2=="slice"){

  if (type=="radius") x<-shtseq$level else x<-matrix(0,lkm,1)

  td<-shtseq$shtseq[[1]]
  if (type=="proba") td$volume<-td$proba
  td<-treedisc(td,shtseq$pcf,ngrid=ngrid)
  xy<-lst2xy(td,gnum=gnum)
  ylen<-length(xy$x)
  ystep<-1/(ylen-1)
  y<-seq(0,1,ystep)   #matrix(0,xlen,1)
  z<-matrix(0,length(x),length(y))
  delineator<-matrix(0,10*length(x),d)
  delinrun<-1
  delineatorlevel<-matrix(0,10*length(x),1)
  
  delineator.redu<-matrix(0,4*length(x),d)
  dr.redu<-1
  delineatorlevel.redu<-matrix(0,4*length(x),1)

  for (i in 1:lkm){
     td<-shtseq$shtseq[[i]]

     if (type=="proba"){ 
         tdvolume<-td$volume
         td$volume<-td$proba
         indi<-lkm-i+1
         voluu<-max(tdvolume)  #[1]  #root=1
         if (norma) x[indi]<-(voluu/volball(1,d))^(1/d)
         else x[indi]<-voluu 
     }
     else indi<-i
     td<-treedisc(td,shtseq$pcf,ngrid=ngrid)
     if (length(td$parent)==1) ynew<-0
     else{
        xy<-lst2xy(td,gnum=gnum)   #ma<-matchxy(xy$x,xy$y,y)

        ## normalize
        volu<-xy$x[length(xy$x)]-xy$x[1]
        int<-0
        step<-xy$x[2]-xy$x[1]
        for (j in 1:length(xy$x)){
            int<-int+step*xy$y[j]
        }
        if (norma){
            normavolu<-(volu/volball(1,d))^(1/d)
            b<-volu*normavolu/int
        }
        else b<-volu^2/int
        ynew<-b*xy$y
        ## end normalize

        # location
        ml<-moodilkm(td$parent)
        mc<-t(td$center[,ml$modloc])  #modecent(td)
        modenum<-dim(mc)[1]
        delineator[delinrun:(delinrun+modenum-1),]<-mc     
        delineatorlevel[delinrun:(delinrun+modenum-1)]<-x[indi] 
        delinrun<-delinrun+modenum

        if (modenum>modelim){
            prunum<-modenum-modelim
            pru<-prunemodes(td,prunum,exmalim,num=maxnum)
        }
        else pru<-td 
        ml<-moodilkm(pru$parent)
        mc<-t(pru$center[,ml$modloc])  #modecent(td)
        modenum<-dim(mc)[1]
        delineator.redu[dr.redu:(dr.redu+modenum-1),]<-mc     
        delineatorlevel.redu[dr.redu:(dr.redu+modenum-1)]<-x[indi] 
        dr.redu<-dr.redu+modenum
     }
     z[indi,]<-ynew   
  }
  delineator<-delineator[1:(delinrun-1),]
  delineatorlevel<-delineatorlevel[1:(delinrun-1)]

  delineator.redu<-delineator.redu[1:(dr.redu-1),]
  delineatorlevel.redu<-delineatorlevel.redu[1:(dr.redu-1)]
}

else{ #type2=="boundary"

if (is.null(xmax)){
    td<-shtseq$shtseq[[1]]
    if (type=="proba") td$volume<-td$proba
    xmax<-max(td$volume)
}

ymax<-xmax
step<-2*xmax/(gnum-1)
x<-seq(-xmax,xmax,step)
y<-x
z<-matrix(0,length(x),length(y))

for (i in 1:lkm){
  td<-shtseq$shtseq[[i]]
  if (type=="proba") td$volume<-td$proba
  xy<-lst2xy(td,gnum=gnum2,type=type)  

  ## normalize
  volu<-xy$x[length(xy$x)]-xy$x[1]
  int<-0
  step<-xy$x[2]-xy$x[1]
  for (j in 1:length(xy$x)){
       int<-int+step*xy$y[j]
  }
  b<-volu^2/int
  ynew<-b*xy$y
  ## end normalize

  for (j in 1:length(x)){
      for (k in 1:length(y)){
          len<-sqrt(x[j]^2+y[k]^2)
          xn<-x[j]/len
          yn<-y[k]/len
          th2<-atan(xn/yn)
          if (yn<0) th2<-atan(xn/yn)+pi else if (xn<0) th2<-atan(xn/yn)+2*pi
          propo<-th2/(2*pi) 
          dirind<-max(1,round( propo*length(xy$x) ))
          rho<-ynew[dirind]
          if (len<=rho) z[j,k]<-shtseq$level[i]
      }
  }
}

}

return(list(x=x,y=y,z=z,type=type,type2=type2,norma=norma,
            delineator=delineator,delineatorlevel=delineatorlevel,
            delineator.redu=delineator.redu,
            delineatorlevel.redu=delineatorlevel.redu))
}


shapetree<-function(et,lev,bary,ordmet="etaisrec",levmet="proba")
{
# et is an evaluation tree

d<-length(et$step)

# order the atoms for the level set with level "lev"

lenni<-length(et$value)
distat<-matrix(0,lenni,1)
infopointer<-matrix(0,lenni,1)
lkm<-0
for (i in 1:lenni){
  if (et$value[i]>=lev){
     lkm<-lkm+1
     nod<-i  #nod<-et$nodefinder[i]
     if (ordmet=="etaisrec"){
         recci<-matrix(0,2*d,1)
         for (jj in 1:d){
            recci[2*jj-1]<-et$support[2*jj-1]+et$step[jj]*et$low[nod,jj]
            recci[2*jj]<-et$support[2*jj-1]+et$step[jj]*et$upp[nod,jj]
         }
         distat[lkm]<-etaisrec(bary,recci)
     }
     else{
        lowi<-matrix(0,d,1)
        uppi<-matrix(0,d,1)
        for (jj in 1:d){
            lowi[jj]<-et$support[2*jj-1]+et$step[jj]*et$low[nod,jj]
            uppi[jj]<-et$support[2*jj-1]+et$step[jj]*et$upp[nod,jj]
        }
        baryc<-lowi+(uppi-lowi)/2  #et$low[nod,]+(et$upp[nod,]-et$low[nod,])/2  
        distat[lkm]<-etais(baryc,bary)
     }
     infopointer[lkm]<-i
  }
}
distat<-distat[1:lkm]
infopointer<-infopointer[1:lkm]   #pointe->et$value,et$nodefinder

ord<-order(distat)
infopointer<-infopointer[ord]

# create tree

parent<-matrix(0,lkm,1)
child<-matrix(0,lkm,1)
sibling<-matrix(0,lkm,1)
volume<-matrix(0,lkm,1)
center<-matrix(0,lkm,d)
radius<-matrix(0,lkm,1)

proba<-matrix(0,lkm,1)
ekamome<-matrix(0,lkm,d)
highestNext<-matrix(0,lkm,1)    #pointers to the nodes without parent
boundrec<-matrix(0,lkm,2*d) #for each node, the box which bounds all the c:dren

node<-lkm  #ord[lkm]  #the 1st child node is the one with the longest distance
parent[node]<-0
child[node]<-0
sibling[node]<-0
# volume calculation
vol<-1
k<-1
ip<-infopointer[node]  #et$nodefinder[infopointer[node]]
while (k<=d){
    vol<-vol*(et$upp[ip,k]-et$low[ip,k])*et$step[k]
    k<-k+1
}
volume[node]<-vol
ip2<-infopointer[node]
proba[node]<-et$value[ip2]*vol
radius[node]<-distat[ord[node]]
# ekamome calculation
newcente<-matrix(0,d,1)
for (j in 1:d){
  volmin<-1
  k<-1
  while (k<=d){
      if (k!=j){
         volmin<-volmin*(et$upp[ip,k]-et$low[ip,k])*et$step[k]
      }
      k<-k+1
  }
  ala<-et$support[2*j-1]+et$step[j]*et$low[ip,j]
  yla<-et$support[2*j-1]+et$step[j]*et$upp[ip,j]
  newcente[j]<-volmin*(yla^2-ala^2)/2
}
ekamome[node,]<-newcente

beg<-node             #first without parent
highestNext[node]<-0
note<-infopointer[node]   #note<-et$nodefinder[infopointer[node]]
for (i in 1:d){
  boundrec[node,2*i-1]<-et$low[note,i]   
  boundrec[node,2*i]<-et$upp[note,i]  #et$index[infopointer[node],i]
}

j<-2
while (j<=lkm){
    node<-lkm-j+1   #ord[lkm-j+1]

    # lisaa "node" ensimmaiseksi listaan
    highestNext[node]<-beg  #beg on listan tamanhetkinen ensimmainen
    beg<-node           

    # add node-singleton to boundrec
    rec1<-matrix(0,2*d,1)  #luo sigleton
    note<-infopointer[node]  #note<-et$nodefinder[infopointer[node]]
    for (i in 1:d){
         rec1[2*i-1]<-et$low[note,i]  
         rec1[2*i]<-et$upp[note,i] 
    }
    boundrec[node,]<-rec1

    # volume calculation
    vol<-1
    k<-1
    ip<-infopointer[node]    #et$nodefinder[infopointer[node]]
    while (k<=d){
          vol<-vol*(et$upp[ip,k]-et$low[ip,k])*et$step[k]
          k<-k+1
    }
    volume[node]<-vol
    ip2<-infopointer[node]
    proba[node]<-et$value[ip2]*vol
    radius[node]<-distat[ord[node]]
    # ekamome calculation
    newcente<-matrix(0,d,1)
    for (jj in 1:d){
         volmin<-1
         k<-1
         while (k<=d){
            if (k!=jj){
                volmin<-volmin*(et$upp[ip,k]-et$low[ip,k])*et$step[k]
            }
            k<-k+1
         }
         ala<-et$support[2*jj-1]+et$step[jj]*et$low[ip,jj]
         yla<-et$support[2*jj-1]+et$step[jj]*et$upp[ip,jj]
         newcente[jj]<-volmin*(yla^2-ala^2)/2
    }
    ekamome[node,]<-newcente

    curroot<-highestNext[beg]  #node on 1., listassa ainakin 2
    prevroot<-beg
    ekatouch<-0
    while (curroot>0){
        istouch<-touchstep(node,curroot,boundrec,child,sibling,
                           infopointer,et$low,et$upp)
        if (istouch==1){
{
           # paivita parent, child, sibling, volume ekamome
           parent[curroot]<-node           
           if (ekatouch==0) ekatouch<-1 else ekatouch<-0 
           if (ekatouch==1){
              child[node]<-curroot
           }
           else{  # since ekatouch==0, prevroot>0
              sibling[lastsib]<-curroot
           }
           volume[node]<-volume[node]+volume[curroot]
           proba[node]<-proba[node]+proba[curroot]
           ekamome[node,]<-ekamome[node,]+ekamome[curroot,]
           radius[node]<-min(distat[ord[node]],distat[ord[curroot]])

           # attach box of curroot
           rec1<-boundrec[node,]
           rec2<-boundrec[curroot,] 
           boundrec[node,]<-boundbox(rec1,rec2)
           # poista "curroot" listasta 
           highestNext[prevroot]<-highestNext[curroot]
}
        }     
        # if curroot was not removed, we update prevroot
        # else curroot was removed, we update lastsib
        if (istouch==0) prevroot<-curroot else lastsib<-curroot 
        curroot<-highestNext[curroot]
    }
    j<-j+1
}

root<-1 #ord[1]  #root is the barycenter
for (i in 1:lkm){
   for (j in 1:d){
       center[i,j]<-ekamome[i,j]/volume[i]
   }
}

if (levmet=="proba")
level<-taillevel(root,#child,sibling,
parent,volume,proba)
else level<-radius

return(list(
parent=parent,volume=volume,center=t(center),level=level,
root=root,
#child=child,sibling=sibling,  #virhe??
infopointer=infopointer,
proba=proba,radius=radius,
bary=bary,maxdis=distat[ord[length(ord)]]))

}





siborder.new<-function(mt)
{
#mt is multitree

itemnum<-length(mt$child)
sibord<-matrix(0,itemnum,1)

#order first roots

rootnum<-length(mt$roots)
for (i in 1:rootnum) sibord[mt$roots[i]]<-i

# then order the other

for (i in 1:rootnum){
   curroot<-mt$roots[i]
   if (mt$child[curroot]>0){
      pino<-matrix(0,itemnum,1)
      pino[1]<-mt$child[curroot]
      pinin<-1
      while (pinin>0){
          cur<-pino[pinin]      #take from stack
          pinin<-pinin-1
          # if not yet ordered, order siblings
          if (sibord[cur]==0){
              indu<-1
              sibord[cur]<-indu
              runner<-cur
              while (mt$sibling[runner]>0){
                  sibord[mt$sibling[runner]]<-indu
                  indu<-indu+1  
                  runner<-mt$sibling[runner] 
              }
          }
          # put to the stack 
          if (mt$sibling[cur]>0){
                 pinin<-pinin+1
                 pino[pinin]<-mt$sibling[cur]
          }
          # go to left and put right nodes to the stack
          while (mt$child[cur]>0){   
             cur<-mt$child[cur]
             # if not yet ordered, order siblings
             if (sibord[cur]==0){
                 indu<-1
                 sibord[cur]<-indu
                 runner<-cur
                 while (mt$sibling[runner]>0){
                     sibord[mt$sibling[runner]]<-indu
                     indu<-indu+1  
                     runner<-mt$sibling[runner]
                 }
             }
             if (mt$sibling[cur]>0){
                 pinin<-pinin+1
                 pino[pinin]<-mt$sibling[cur]
             }
           }
       }
   }
}                                  
return(sibord)
}















siborder<-function(mt,crit,centers)
{
#mt is multitree

roots<-mt$roots
child<-mt$child
sibling<-mt$sibling

itemnum<-length(child)
sibord<-matrix(0,itemnum,1)

#order first roots

rootnum<-length(roots)
if (rootnum==1){
  sibord[roots[1]]<-1
}
else{
  rootlink<-matrix(0,itemnum,1)
  for (i in 1:(rootnum-1)){
     inde<-roots[i]
     rootlink[inde]<-roots[i+1]
  }
  sibord<-levord(roots[1],rootlink,sibord,centers,crit)
}

# then order the other

for (i in 1:rootnum){
   curroot<-roots[i]
   if (child[curroot]>0){
      pino<-matrix(0,itemnum,1)
      pino[1]<-child[curroot]
      pinin<-1
      while (pinin>0){
          cur<-pino[pinin]      #take from stack
          pinin<-pinin-1
          # if not yet ordered, order siblings
          if (sibord[cur]==0){
              sibord<-levord(cur,sibling,sibord,centers,crit)
          }
          # put to the stack 
          if (sibling[cur]>0){
                 pinin<-pinin+1
                 pino[pinin]<-sibling[cur]
          }
          # go to left and put right nodes to the stack
          while (child[cur]>0){   
             cur<-child[cur]
             # if not yet ordered, order siblings
             if (sibord[cur]==0){
                sibord<-levord(cur,sibling,sibord,centers,crit)
             }
             if (sibling[cur]>0){
                 pinin<-pinin+1
                 pino[pinin]<-sibling[cur]
             }
           }
       }
   }
}                                  
return(sibord)
}















siborToModor<-function(tree){
#
# From ordering in siblings to ordering of modes
# We have the right ordering in profile
#
data<-plotprof(tree,plot=F,data=T,cutlev=NULL,ptext=0,info=NULL,
infolift=0,infopos=0)
vecs<-data$vecs
#
parent<-tree$parent
mlkm<-moodilkm(parent)
modloc<-mlkm$modloc
moodinum<-mlkm$lkm    #length(modloc)
#
xcor<-matrix(0,moodinum,1)
for (i in 1:moodinum){
    loc<-modloc[i]
    xcor[i]<-vecs[loc,1]    
}
modloc<-omaord2(modloc,xcor)       
#
return(modloc)
}
sim.1d2modal<-function(n=NULL,seed=1,N=NULL,distr=FALSE)
{
d<-1
M<-c(0,2,4)
mixnum<-length(M)
sig<-matrix(1,mixnum,d)
sig[1]<-0.3
p<-matrix(1,mixnum,1)
p[2]<-2
p<-p/sum(p)

if (!is.null(n)){
   dendat<-simmix(n=n,M,sig,p,seed=seed,d=1)
   return(dendat)
}

if (!is.null(N)){
    xala<--2
    xyla<-7
    support<-c(xala,xyla)
    eg<-pcf.func("mixt",N,sig=sig,M=M,p=p,support=support,distr=distr)
    return(eg)
}

if (is.null(N) && is.null(n)){
   return(list(M=M,sig=sig,p=p))
}

}


sim.claw<-function(n=NULL,seed=1,N=NULL)
{
d<-1

M<-c(0,-1,-0.5,0,0.5,1)
sig<-c(1,0.1,0.1,0.1,0.1,0.1)
p<-c(0.5,0.1,0.1,0.1,0.1,0.1)
mixnum<-length(M)

if (!is.null(n)){
   dendat<-simmix(n=n,M,sig,p,seed=seed,d=1)
   return(dendat)
}

if (!is.null(N)){
    support<-c(-3,3)
    eg<-pcf.func("mixt",N,sig=sig,M=M,p=p,support=support)
    return(eg)
}

if (is.null(N) && is.null(n)){
   return(list(M=M,sig=sig,p=p))
}

}


sim.cross<-function(n=NULL,seed=1,N=NULL,sig1=0.5,sig2=1.5)
{
d<-2
mixnum<-2
M<-matrix(0,mixnum,d)
M[1,]<-c(0,0)      
M[2,]<-c(0,0)      
sig<-matrix(1,mixnum,d)
sig[1,1]<-sig1 
sig[1,2]<-sig2   
sig[2,1]<-sig2   
sig[2,2]<-sig1  
p<-matrix(1,mixnum,1)
p<-p/sum(p)

if (!is.null(n)){
   dendat<-simmix(n,M,sig,p,seed=seed)  
   theta<-pi/4
   rotmat<-matrix(c(cos(theta),-sin(theta),sin(theta),cos(theta)),2,2)
   dendat<-dendat%*%rotmat
   return(dendat)
}

if (!is.null(N)){
    theta<-pi/4
    eg<-pcf.func("mixt",N,sig=sig,M=M,p=p,theta=theta)
    return(eg)
}

if (is.null(N) && is.null(n)){
   return(list(M=M,sig=sig,p=p,theta=theta))
}

}


sim.data<-function(n=NULL,seed=1,N=NULL,type="mulmod",
M=NULL,sig=NULL,p=NULL,d=NULL,
cova=NULL,marginal=NULL,t=NULL,df=NULL,distr=FALSE, noisedim=1,
sig1=0.5,sig2=1.5,diff=0.1,dist=4)
{
if (type=="mixt") return( simmix(n,M,sig,p,seed,d) )

if (type=="mulmod") return( sim.mulmod(n=n,seed=seed,N=N) )

if (type=="fox") return( sim.fox(n=n,seed=seed,N=N) )

if (type=="tetra3d") return( sim.tetra3d(n=n,seed=seed,N=N) )

if (type=="penta4d") return( sim.penta4d(n=n,seed=seed,N=N,dist=dist) )

if (type=="cross") return( sim.cross(n=n,seed=seed,N=N,sig1=sig1,sig2=sig2) )

if (type=="1d2modal") return( sim.1d2modal(n=n,seed=seed,N=N,distr=distr) )

if (type=="claw") return( sim.claw(n=n,seed=seed,N=N) )

if (type=="fssk") return( sim.fssk(n=n,noisedim=noisedim,seed=seed) )

if (type=="nested") return( sim.nested(n=n,seed=seed,N=N) )

if (type=="peaks") return( sim.peaks(n=n,seed=seed,N=N) )

if (type=="mulmodII") return( sim.mulmodII(n=n,seed=seed,N=N) )

if (type=="gauss"){
   eig<-eigen(cova,symmetric=TRUE)
   sigsqm<-eig$vectors%*%diag(eig$values^{1/2})  
   set.seed(seed)
   symmedata<-matrix(rnorm(2*n),n,2)
   dendat<-t(sigsqm%*%t(symmedata))
   if (!is.null(marginal)){
      dendat[,1]<-pnorm(dendat[,1],sd=sqrt(cova[1,1]))
      dendat[,2]<-pnorm(dendat[,2],sd=sqrt(cova[2,2]))
      if (marginal=="student") dendat<-qt(dendat, df=t)
      if (marginal=="gauss") dendat<-qnorm(dendat)
   }
   return(dendat)
}

if (type=="student"){
   eig<-eigen(cova,symmetric=TRUE)
   sigsqm<-eig$vectors%*%diag(eig$values^{1/2})  
   set.seed(seed)
   symmedata<-matrix(rt(2*n,df=df),n,2)
   dendat<-t(sigsqm%*%t(symmedata))
   if (!is.null(marginal)){
       dendat<-pt(dendat,df=df)
       if (marginal=="gauss") dendat<-qnorm(dendat)
   }
   return(dendat)
}

if (type=="gumbel"){
  link<-function(y,g){ return ( (-log(y))^g ) }
  linkinv<-function(y,g){ return ( exp(-y^(1/g)) ) }
  der1<-function(y,g){ return ( -g*(-log(y))^(g-1)/y ) }
  der1inv<-function(y,g){ return ( y ) }
}

if (type=="diff1d"){
   xala<--0
   xyla<-1
   support<-c(xala,xyla)
   d<-1
   M<-c(0.5-diff,0.5+diff)
   mixnum<-length(M)
   sig<-matrix(sig1,mixnum,d)
   p<-matrix(1,mixnum,1)
   p<-p/sum(p)
   pcf<-pcf.func("mixt",N=N,sig=sig,M=M,p=p,support=support,distr=distr)
   return(pcf)
}

}

sim.fox<-function(n=NULL,seed=1,N=NULL)
{
d<-2
mixnum<-14
D<-1.8
M<-matrix(0,mixnum,d)
M[1,]<-c(0,0)      #c(0,0)

M[2,]<-c(D,0)      #c(D1,0)
M[3,]<-c(2*D,0)

M[4,]<-c(0,D)
M[5,]<-c(0,2*D)
M[6,]<-c(0,3*D)

M[7,]<-c(0,-D)
M[8,]<-c(0,-2*D)
M[9,]<-c(0,-3*D)

M[10,]<-c(1.5,3.9*D)
M[11,]<-c(-1.5,3.7*D)
M[12,]<-c(-1.5,4.2*D)
M[13,]<-c(-1.5,4.5*D)
M[14,]<-c(-1.5,4.7*D)

sig<-matrix(1,mixnum,d)
sig[10,1]<-0.7
sig[11,1]<-0.7
sig[12,1]<-0.7
sig[13,1]<-0.7
sig[14,1]<-0.7
p<-matrix(1,mixnum,1)
p[6]<-0.6
p[10]<-0.3
p[11]<-0.25
p[12]<-0.1
p[13]<-0.05
p[14]<-0.05
p<-p/sum(p)

if (!is.null(n)){
   dendat<-simmix(n=n,M,sig,p,seed=seed)
   return(dendat)
}

if (!is.null(N)){
    #eg<-evalgrid(M,sig,p,N)
    eg<-pcf.func("mixt",N,sig=sig,M=M,p=p)
    return(eg)
}

if (is.null(N) && is.null(n)){
   return(list(M=M,sig=sig,p=p))
}

}


sim.fssk<-function(n,noisedim,seed)
{
# makes n*d data matrix, d=2+noisedim
# 3 moodia, (c,0), (-c,3), (-c,-3)

d<-2+noisedim
hajo<-1
noisehajo<-sqrt(7)
c<-3^(3/2)/2
set.seed(seed)
data<-matrix(rnorm(d*n),,d)   #n*d matriisi, valkoista kohinaa
data[,1:2]<-hajo*data[,1:2]
if (noisedim>0) data[,3:d]<-noisehajo*data[,3:d]
i<-1
while (i<=n){
  mu<-matrix(0,1,d)       #moodin keskipiste
  ehto<-runif(1)
  if (ehto<1/3){          #sekoitteiden painot samat
         mu[1,1]<-0
         mu[1,2]<-c
  } 
  else if (ehto>2/3){
         mu[1,1]<-3
         mu[1,2]<--c
  }
  else{
         mu[1,1]<--3
         mu[1,2]<--c
  }
  data[i,]<-data[i,]+mu
  i<-i+1
}
return(data)
}






























simmix1d<-function(n,M,sig,p,seed){
#Simulates a mixture of l normal distributions in R^1,
#
#n is the sample size
#M is l-vector, rows are the means
#sig is l-vector, for l:th mixture variance
#p is l-vector, proportion for each mixture
#
#returns n*d-matrix
#
set.seed(seed) 
l<-length(M)
d<-1
data<-rnorm(n)        #n-vektori valkoista kohinaa 
for (i in 1:n){
   ehto<-runif(1)
   alku<-0
   loppu<-p[1]
   lippu<-0
   for (j in 1:(l-1)){
      if ((alku<=ehto) && (ehto<loppu)){
         data[i]<-sig[j]*data[i]+M[j]
         lippu<-1
      }
      alku<-alku+p[j]
      loppu<-loppu+p[j+1]
   }      
   if (lippu==0) data[i]<-sig[l]*data[i]+M[l]
}
data<-t(t(data))  #we make a n*1 matrix
return(data)
}
simmix<-function(n,M,sig,p,seed,d=NULL)
{
#Simulates a mixture of l normal distributions in R^d, l>1
#with diagonal cov matrices

#n is the sample size
#M is l*d-matrix, rows are the means
#sig is l*d-matrix, for l:th mixture d covariances
#p is l-vector, proportion for each mixture

#returns n*d-matrix

if (is.null(d)) d<-dim(M)[2] 

set.seed(seed) 
#if (dim(M)[2]==1) d<-1 else d<-length(M[1,]) 
if (d==1){
  data<-simmix1d(n,M,sig,p,seed)
  }
else{
l<-length(M[,1])
data<-matrix(rnorm(d*n),,d) #n*d matriisi, valkoista kohinaa 
for (i in 1:n){
   ehto<-runif(1)
   alku<-0
   loppu<-p[1]
   lippu<-0
   for (j in 1:(l-1)){
      if ((alku<=ehto) && (ehto<loppu)){
         data[i,]<-sig[j,]*data[i,]+M[j,]
         lippu<-1
      }
      alku<-alku+p[j]
      loppu<-loppu+p[j+1]
   }      
   if (lippu==0) data[i,]<-sig[l,]*data[i,]+M[l,]
}
}
return(data)
}
sim.mulmodII<-function(n=NULL,seed=1,N=NULL)
{
d<-2
mixnum<-3
D<-4
M<-matrix(0,mixnum,d)
M[1,]<-c(0,0)   
M[2,]<-c(D,0)  
M[3,]<-c(D/2,D*sqrt(3)/2)   
sig<-matrix(1,mixnum,d)
p<-c(.2,.35,.45)

if (!is.null(n)){
   dendat<-simmix(n=n,M,sig,p,seed=seed)
   return(dendat)
}

if (!is.null(N)){
    #eg<-evalgrid(M,sig,p,N)
    eg<-pcf.func("mixt",N,sig=sig,M=M,p=p)
    return(eg)
}

if (is.null(N) && is.null(n)){
   return(list(M=M,sig=sig,p=p))
}

}


sim.mulmod<-function(n=NULL,seed=1,N=NULL)
{
d<-2
mnum<-3
D<-3.5  #3 
shift<-0.2  
M<-matrix(0,mnum,d)
M[1,]<-c(0,0)
M[2,]<-c(D,shift)   #c(D,0)
M[3,]<-c(D/2,D)    #   #c(D/2,D*sqrt(3)/2)
sig<-matrix(1,mnum,d)
p<-c(.25,.35,.45)
p<-p/sum(p)

if (!is.null(n)){
   dendat<-simmix(n=n,M,sig,p,seed=seed)
   return(dendat)
}

if (!is.null(N)){
    #eg<-evalgrid(M,sig,p,N)
    eg<-pcf.func("mixt",N,sig=sig,M=M,p=p)
    return(eg)
}

if (is.null(N) && is.null(n)){
   return(list(M=M,sig=sig,p=p))
}

}


sim.nested<-function(n=NULL,seed=1,N=NULL)
{
d<-2
con<-3^(3/2)/2
shift<-0.8
std<-0.3
mnum<-5
M<-matrix(0,mnum,d)
M[1,]<-c(0,con)
M[2,]<-c(3,-con)
M[3,]<-c(-3,-con) 
M[4,]<-c(shift,con)
M[5,]<-c(-shift,con)

sig<-matrix(1,mnum,d)
sig[4,]<-c(std,std)
sig[5,]<-c(std,std)
p<-c(5/7/3,5/7/3,5/7/3,1/7,1/7)
p<-p/sum(p)

if (!is.null(n)){
   dendat<-simmix(n=n,M,sig,p,seed=seed)
   return(dendat)
}

if (!is.null(N)){
    #eg<-evalgrid(M,sig,p,N)
    eg<-pcf.func("mixt",N,sig=sig,M=M,p=p)
    return(eg)
}

if (is.null(N) && is.null(n)){
   return(list(M=M,sig=sig,p=p))
}

}


sim.peaks<-function(n=NULL,seed=1,N=NULL)
{
d<-2
mnum<-5
D<-3.5  
shift<-0.6
M<-matrix(0,mnum,d)
M[1,]<-c(0,0)
M[2,]<-c(D,0)
M[3,]<-c(D/2,D)       #c(D/2,D*sqrt(3)/2)
M[4,]<-c(shift+D/2,D)
M[5,]<-c(-shift+D/2,D)

sig<-matrix(1,mnum,d)
std<-0.3
sig[4,]<-c(std,std)
sig[5,]<-c(std,std)

#p<-c(.25,.35,.45)
p<-c(6/8/3,6/8/3,6/8/3,1/8,1/8)
p<-p/sum(p)

if (!is.null(n)){
   dendat<-simmix(n=n,M,sig,p,seed=seed)
   return(dendat)
}

if (!is.null(N)){
    eg<-pcf.func("mixt",N,sig=sig,M=M,p=p)
    return(eg)
}

if (is.null(N) && is.null(n)){
   return(list(M=M,sig=sig,p=p))
}

}


sim.penta4d<-function(n=NULL,seed=1,N=NULL,dist=4)
{
d<-4
moodi<-5
M<-matrix(0,moodi,d)
#dist<-4     # determine the distance between vertices of the pentahedron
M[1,]<-dist*c(1/2, 0,0,0)
M[2,]<-dist*c(-1/2,0,0,0)
M[3,]<-dist*c(0,sqrt(3)/2,0,0)
M[4,]<-dist*c(0,1/(2*sqrt(3)),sqrt(2/3),0)
M[5,]<-dist*c(0,1/(2*sqrt(3)),1/(2*sqrt(6)),sqrt(15/24))
sig<-matrix(1,moodi,d)
p0<-1/moodi
p<-p0*rep(1,moodi)

if (!is.null(n)){
   dendat<-simmix(n=n,M,sig,p,seed=seed)
   return(dendat)
}

if (!is.null(N)){
    #eg<-evalgrid(M,sig,p,N)
    eg<-pcf.func("mixt",N,sig=sig,M=M,p=p)
    return(eg)
}

if (is.null(N) && is.null(n)){
   return(list(M=M,sig=sig,p=p))
}

}


sim.tetra3d<-function(n=NULL,seed=1,N=NULL)
{
dist<-3    # determine the distance between vertices of the tetrahedron

d<-3
moodi<-4
M<-matrix(0,moodi,d)
height<-sqrt(3)/2           # sqrt(3)/2 = 0.8660254
len<-1/(2*sqrt(3))          # 1/(2*sqrt(3)) = 0.2886751
kor<-sqrt(2/3)              # sqrt(2/3) = 0.8164966
M[1,]<-dist*c(1/2,0,0)      # ( 1.5, 0.0, 0.0)
M[2,]<-dist*c(-1/2,0,0)     # (-1.5, 0.0, 0.0)
M[3,]<-dist*c(0,height,0)   # ( 0.0, 2.6, 0.0)
M[4,]<-dist*c(0,len,kor)    # ( 0.0, 0.9, 2.4)
sig<-matrix(1,moodi,d)
p0<-1/moodi
p<-p0*rep(1,moodi)

if (!is.null(n)){
   dendat<-simmix(n=n,M,sig,p,seed=seed)
   return(dendat)
}

if (!is.null(N)){
    eg<-pcf.func("mixt",N,sig=sig,M=M,p=p)
    return(eg)
}

if (is.null(N) && is.null(n)){
   return(list(M=M,sig=sig,p=p))
}

}


simukern<-function(n,d,seed,newvalue,index,delta,minim,h){
#
set.seed(seed)
dendat<-matrix(0,n,d)
volofatom<-prod(delta)
newvalue<-newvalue/sum(volofatom*newvalue)
#
for (i in 1:n){
   uni<-runif(1)
   cumyla<-newvalue[1]*volofatom
   run<-1
   while (cumyla<uni){
      run<-run+1 
      cumyla<-cumyla+newvalue[run]*volofatom
   }
   #run leads to the right bin
   inde<-index[run,]
   uni2<-runif(1)                #add blur in bin
   obse<-minim-h+delta*inde+delta*(uni2-1/2)
   dendat[i,]<-obse
}
return(dendat)
}
slicing<-function(pcf,vecci,d1=1,d2=NULL)
# 1D slice: we calculate the slice parallel to the direction d1
# when d1=1, we calculate f(t,vecci) 
{
lenni<-length(pcf$value)
value<-matrix(0,lenni,1)
d<-length(pcf$N)
step<-matrix(0,d,1)
for (kk in 1:d) step[kk]<-(pcf$support[2*kk]-pcf$support[2*kk-1])/pcf$N[kk]

if  (is.null(d2)){  #1D slice

index<-matrix(0,lenni,1)

efek<-0
for (i in 1:lenni){

  currec<-matrix(0,2*d,1)
  for (kk in 1:d){
     currec[2*kk-1]<-pcf$support[2*kk-1]+pcf$down[i,kk]*step[kk]
     currec[2*kk]<-pcf$support[2*kk-1]+pcf$high[i,kk]*step[kk]
  }
  
  dimcal<-0
  onvalissa<-T
  j<-1
  while (j<=d){

     if (j!=d1){    
         ala<-currec[2*j-1]
         yla<-currec[2*j]
         if ((ala>vecci[j-dimcal]) || (yla<vecci[j-dimcal])) onvalissa<-F
     }
     else dimcal<-dimcal+1
     j<-j+1
  }
  if (onvalissa){
     efek<-efek+1
     value[efek]<-pcf$value[i]
     index[efek,1]<-pcf$high[i,d1]
  }
}

value<-value[1:efek]
index<-index[1:efek]
support<-pcf$support[(2*d1-1):(2*d1)]
N<-pcf$N[d1]
down<-matrix(0,efek,1)
high<-matrix(0,efek,1)
down[,1]<-index-1
high[,1]<-index
#down<-index-1
#high<-index

return(list(value=value,index=index,support=support,N=N,down=down,high=high))

}
else{ # 2D slice

if (is.null(d2)) d2<-2

down<-matrix(0,lenni,2)
high<-matrix(0,lenni,2)

efek<-0
for (i in 1:lenni){

  currec<-matrix(0,2*d,1)
  for (kk in 1:d){
     currec[2*kk-1]<-pcf$support[2*kk-1]+pcf$down[i,kk]*step[kk]
     currec[2*kk]<-pcf$support[2*kk-1]+pcf$high[i,kk]*step[kk]
  }
  
  dimcal<-0
  onvalissa<-T
  j<-1
  while (j<=d){

     if ((j!=d1) && (j!=d2)){    
         ala<-currec[2*j-1]
         yla<-currec[2*j]
         if ((ala>vecci[j-dimcal]) || (yla<vecci[j-dimcal])) onvalissa<-F
     }
     else dimcal<-dimcal+1
     j<-j+1
  }
  if (onvalissa){
     efek<-efek+1
     value[efek]<-pcf$value[i]
     down[efek,1]<-pcf$down[i,d1]
     down[efek,2]<-pcf$down[i,d2] 
     high[efek,1]<-pcf$high[i,d1]
     high[efek,2]<-pcf$high[i,d2] 
  }
}

value<-value[1:efek]
down<-down[1:efek,]
high<-high[1:efek,]
support<-c(pcf$support[(2*d1-1):(2*d1)],pcf$support[(2*d2-1):(2*d2)])

return(list(value=value,down=down,high=high,
support=support,N=c(pcf$N[d1],pcf$N[d2])))
} #else 2D slice

}




stseq<-function(N,lnum,
refe=NULL,func=NULL,dendat=NULL,
h=NULL,Q=NULL,kernel="epane",weights=NULL,
sig=rep(1,length(N)),support=NULL,theta=NULL,
M=NULL,p=NULL,mul=3,
t=rep(1,length(N)),marginal="normal",r=0,
mu=NULL,xi=NULL,Omega=NULL,alpha=NULL,df=NULL,g=1,
base=10
)
{
#lnum<-length(lseq)
level<-matrix(0,lnum,1)
volume<-matrix(0,lnum,1)
if (!is.null(dendat)) 
  pcf<-pcf.kern(dendat,h,N,kernel=kernel,weights=weights)
else
  pcf<-pcf.func(func,N,   #eval.func.dD
  sig=sig,support=support,theta=theta,
  M=M,p=p,mul=mul,
  t=t,marginal=marginal,r=r, 
  mu=mu,xi=xi,Omega=Omega,alpha=alpha,df=df,g=g)

maksi<-max(pcf$value)
l1<-maksi/(lnum+1) 
lmax<-maksi*lnum/(lnum+1)
level<-hgrid(l1,lmax,lnum,base=base)
level<-level[length(level):1]

for (i in 1:lnum){   
      #lev<-maksi*i/(lnum+1) 
      #level[i]<-lev 
      lev<-level[i]
      if (is.null(refe)) refe<-locofmax(pcf)
      st<-leafsfirst(pcf,lev=lev,refe=refe)
      volume[i]<-max(st$volume)
      if (i==1){
           if (lnum==1){ 
               istseq<-st
           }
           else{
               stseq<-list(st)
           }
      }
      else{
          stseq<-c(stseq,list(st))
      }
}
return(list(shtseq=stseq,level=level,volume=volume,pcf=pcf))
}



support<-function(dendat,epsi=0)
{
#estimoi kantajan tih datan perusteella
#dendat on n*xlkm matriisi
#epsi on tekn parametri
#kantajaksi estimoidaan [min-epsi,max+epsi]
#palauttaa xlkm*2-matriisin

xlkm<-length(dendat[1,])    #dendat matr sarakk lkm on muuttujien lkm
vast<-matrix(0,xlkm,2)  
i<-1
while (i<=xlkm){
    vast[i,1]<-min(dendat[,i])-epsi     #sis valien alkupisteet
    vast[i,2]<-max(dendat[,i])+epsi     #sis valien paatepisteet
    i<-i+1
}
return(vast)
}


tailfunc<-function(R,d,type,gnum=1000,sig=1,nu=1)
{
volball<-function(r,d){ return(r^d*pi^(d/2)/gamma(d/2+1)) }
volsphere<-function(d){ return(2*pi^(d/2)/gamma(d/2)) }

if (type=="bartlett"){
   norma<-d*(d+2)/(2*volsphere(d))
   funni<-function(t,d=d,nu=nu){ return( t^(d-1)*(1-t^2) ) }
   levfun<-function(t,d=d,sig=sig,nu=nu){ return( 1-(t/sig)^2 ) }
}
if (type=="gauss"){
   norma<-(2*pi)^(-d/2)
   funni<-function(t,d=d,nu=nu){ return( t^(d-1)*exp(-t^2/2) ) }
   levfun<-function(t,d=d,sig=sig,nu=nu){ return( exp(-(t/sig)^2/2) ) }
}
if (type=="student"){
   norma<-gamma((nu+d)/2)/((pi*nu)^(d/2)*gamma(nu/2))
   funni<-function(t,d=d,nu=nu){ return( t^(d-1)*(1+t^2/nu)^(-(d+nu)/2) ) }
   levfun<-function(t,d=d,sig=sig,nu=nu){ return( (1+(t/sig)^2/nu)^(-(d+nu)/2) ) }
}

# probability calc (numerical integral)
# y[r] = int_0^(r/sig) funni(t) dt
stepy<-R/sig/gnum
radiy<-seq(stepy,R/sig,stepy)
y<-matrix(0,length(radiy),1)
y[1]<-stepy*funni(radiy[1],d=d,nu=nu)
for (i in 2:length(y)){
    y[i]<-y[i-1]+stepy*funni(radiy[i],d=d,nu=nu)
}

# level calc
step<-R/gnum
radi<-seq(step,R,step)
level<-matrix(0,length(radi),1)
for (i in 1:length(level)){
    level[i]<-levfun(radi[i],d=d,sig=sig,nu=nu)
}

intrad2lev<-0
step<-radi[2]-radi[1]
for (i in 1:length(level)){
   intrad2lev<-intrad2lev+step*level[i]
}
levelnorma<-level/intrad2lev/2

proba<-norma*volsphere(d)*y
volu<-volball(radi,d)
level<-sig^(-d)*norma*level

return(list(radi=radi,proba=proba,volu=volu,level=level,levelnorma=levelnorma))
}









taillevel<-function(root,#child,sibling,
parent,volume,proba)
{
mt<-multitree(parent)
child<-mt$child
sibling<-mt$sibling

nodenum<-length(child)
level<-matrix(0,nodenum,1)
pino<-matrix(0,nodenum,1)

pino[1]<-root
pinin<-1
while (pinin>0){
      cur<-pino[pinin]      #take from stack
      pinin<-pinin-1

      chi<-child[cur]
      pare<-parent[cur]

      prochi<-0
      nexchi<-chi
      while (nexchi>0){
           prochi<-prochi+proba[nexchi]
           nexchi<-sibling[nexchi]
      }
      if (pare==0) levelpare<-0 else levelpare<-level[pare]

      level[cur]<-levelpare+(proba[cur]-prochi)/volume[cur]

      if (sibling[cur]>0){
            pinin<-pinin+1
            pino[pinin]<-sibling[cur]
      }
      while (child[cur]>0){    #go to left and put right nodes to stack
            cur<-child[cur]

            chi<-child[cur]
            pare<-parent[cur]

            prochi<-0
            nexchi<-chi
            while (nexchi>0){
                 prochi<-prochi+proba[nexchi]
                 nexchi<-sibling[nexchi]
            }
            if (pare==0) levelpare<-0 else levelpare<-level[pare]

            level[cur]<-levelpare+(proba[cur]-prochi)/volume[cur]

            if (sibling[cur]>0){  #if candi has siblings
                pinin<-pinin+1
                pino[pinin]<-sibling[cur]
            } 
      }
}
return(level)

}





til1<-function(runi){
#
if (dim(t(runi))[1]==1) lkm<-1 else lkm<-length(runi[,1])
d<-length(runi[1,])/2
#
if (lkm>=2){
 parimat<-matrix(NA,lkm,lkm) #rivilla i lueteltu ne jotka leikk suorakaid i
                      # blokit tahan !!!!!!!!!!!!!!!!
 touchlkm<-matrix(0,lkm,1)   #kuinka monta kosketusta riv. i olevalle kaiteelle
# parimat2<-matrix(0,lkm,lkm) #rivilla i saralla j on 1 jos i ja j suork.leikk.
 l<-choose(lkm,2)
 curkosk<-matrix(0,l,2)      # blokit tahan !!!!!!!!!!!!!!!!
 currecs<-matrix(0,l,2*d)
 ind<-0
 for (i in 1:lkm){
   viite<-1 
   j<-i+1
   while (j<=lkm){
     ise<-leikkaa(runi[i,],runi[j,])
     if (!is.na(ise)){
       ind<-ind+1
       curkosk[ind,]<-c(i,j)
       currecs[ind,]<-ise 
       touchlkm[i]<-touchlkm[i]+1
       touchlkm[j]<-touchlkm[j]+1    
       parimat[i,touchlkm[i]]<-j
       parimat[j,touchlkm[j]]<-i
#       parimat2[i,j]<-1
#       parimat2[j,i]<-1
     }
     j<-j+1
   }
 }
}
if (ind==1){             #jos oli vain yksi leikkaus
  curkosk<-t(curkosk[1:ind,])
  currecs<-t(currecs[1:ind,])
  }
else if (ind>=2){      #jos oli useampi kuin yksi leikkaus
    curkosk<-curkosk[1:ind,]
    currecs<-currecs[1:ind,]
}
# supistetaan parimat
maxkosk<-max(touchlkm)
parimat<-parimat[,1:maxkosk]
if (maxkosk==1) parimat<-t(t(parimat))
return(list(ind=ind,curkosk=curkosk,currecs=currecs,parimat=parimat))
}






til2<-function(runi,curkosk,currecs,parimat,kosk){
#
blokki<-100
bloknum<-1
curpit<-blokki  # curpit<-lkm*curlkm #pahimillaan jokainen leikkaa jokaista
#
#if (dim(t(parimat))[1]==1) lkm<-1 else lkm<-length(parimat[1,]) 
lkm<-length(parimat[1,])    #kaiteiden maara
curlkm<-length(curkosk[,1]) #curlkm on edellisten kosketusten maara 
edkosk<-length(curkosk[1,]) #aikaisemmin haettiin kaikki leikkaukset
                            #edkosk:n kaiteen valilla  
d<-length(currecs[1,])/2
uuskosk<-matrix(0,curpit,kosk)     #matrix(0,lkm*curlkm,kosk) 
uusrecs<-matrix(0,curpit,2*d)      #matrix(0,lkm*curlkm,2*d)
#
ind<-0
for (i in 1:curlkm){  #kaydaan lapi kaikki nykyiset suorakaiteet
  vipu<-curkosk[i,edkosk] #uuden leikkaavan pitaa leikata esim viim curkosk:ssa
                  #to fasten the algorithm we do not consider every rec:
	          #only those who intersec with 1. in curkosk 
  ehdind<-1      
  ehdokas<-parimat[vipu,ehdind]  #ehdokkaat ovat ne jotka leikkaavat vipua
  while ((!is.na(ehdokas)) && (ehdind<=lkm)){ 
                  #kayd lapi ne jotka leikk vipua
                  #ehdokkaan pitaa leikata kaikkia muitakin 
                  #curkosk:n i:nnella rivilla olevia
    if (ehdokas>vipu){  #hetaan vain suuremmista kuin vipu   
      j<-1     
      touch<-TRUE
      olimuita<-FALSE
      while ((j<=(edkosk-1)) && (touch)){ #kayd lapi muut kuin vipu
        muu<-curkosk[i,j]
        if (!(ehdokas==muu)){
          olimuita<-TRUE
          curkoske<-parimat[ehdokas,]   #ne joihin ehdokas koskettaa
          touch<-onko(curkoske,muu)     #onko muu rivilla "curkoske"  
           #if (parimat2[ehdokas,muu]==0) touch<-FALSE
        }
              #jos ehdokas ja muu eivat kosketa ja ovat eri
	      #jos ehdokas=muu, niin parimat2[ehdokas,muu]=0  
        j<-j+1
      }
      if ((touch) && !(olimuita)) touch<-FALSE
      if (touch){  #jos ehdokas kosketti kaikkia muita
          ind<-ind+1   #lisataan uusien leikkausten laskuria
          if (ind<=curpit){  #jos ei tarvita uutta blokkia     
            uuskosk[ind,]<-c(curkosk[i,],ehdokas)  #???????
            uusrecs[ind,]<-leikkaa(currecs[i,],runi[ehdokas,])
          }
          else{
            bloknum<-bloknum+1
            uuspit<-bloknum*blokki
            apukosk<-matrix(0,uuspit,kosk)
            apurecs<-matrix(0,uuspit,2*d)
            apukosk[1:curpit,]<-uuskosk[1:curpit,]
            apurecs[1:curpit,]<-uusrecs[1:curpit,]
            apukosk[ind,]<-c(curkosk[i,],ehdokas)  #???????
            apurecs[ind,]<-leikkaa(currecs[i,],runi[ehdokas,])
            uuskosk<-apukosk
            uusrecs<-apurecs
            curpit<-uuspit
          }             
      }
    }  
    ehdind<-ehdind+1
    if (ehdind<=lkm) ehdokas<-parimat[vipu,ehdind] 
                                     #otetaan uusi vipua leikkaava
  }
}
if (ind>0){ 
       curkosk<-uuskosk[1:ind,]
       currecs<-uusrecs[1:ind,]
}     
return(list(ind=ind,currecs=currecs,curkosk=curkosk))
}








til<-function(runi){
#
if (dim(t(runi))[1]==1) lkm<-1 else lkm<-length(runi[,1])
masses<-matrix(0,lkm,1)
#
masses[1]<-sum(massat(runi))    #kaiteiden massojen summa
#
if (lkm>=2){
 apu<-til1(runi)
 ind<-apu$ind
 curkosk<-apu$curkosk
 currecs<-apu$currecs
 parimat<-apu$parimat
 if (ind>0){ #jos oli parittaisia leikkauksia
    masses[2]<-sum(massat(currecs)) #parittaisten leikkausten massojen summa
    kosk<-3
    while (ind>1){
      write(ind,file="apu",append=TRUE)
      apu2<-til2(runi,curkosk,currecs,parimat,kosk)
      ind<-apu2$ind
      if (ind>0){
        currecs<-apu2$currecs
        curkosk<-apu2$curkosk
        masses[kosk]<-sum(massat(currecs))
      }
      kosk<-kosk+1
    }
 }
}
res<-0                 # res<-til3(masses)
for (i in 1:lkm){
  res<-res+(-1)^(i-1)*masses[i]
}                                 
return(res)
}
touchi<-function(rec1,rec2,rho=0)
{
#Checks whether rectangles rec1, rec2 touch.
#rec1,rec2 are 2*d vectors, discrete rectangles (grid)

#Returns 0 if intersection is empty

d<-length(rec1)/2
if (length(rho)==1) rho<-rep(rho,d)

tulos<-1
i<-1
while ((i<=d) && (tulos==1)){  
    ala<-max(rec1[2*i-1],rec2[2*i-1])
    yla<-min(rec1[2*i],rec2[2*i])
    if (yla+2*rho[i]<ala) tulos<-0
    i<-i+1
}
return(tulos)
}




touchi.tail<-function(rec1,rec2,r1,r2=NULL,dist.type="euclid")
{
# Returns 0 if intersection is empty.
# rec1 is d-vector
# rec2 is d-vector or 2*d vector (rectangle)

d<-length(rec1)

if (dist.type=="euclid"){

if (length(rec2)==2*d){  # rec2 is 2*d vector (rectangle)
 
   point<-rec1
   rec<-rec2
   dist<-0
   for (i in 1:d){
      if (point[i]>rec[2*i]) 
          dist<-dist+(point[i]-rec[2*i])^2
      else if (point[i]<rec[2*i-1]) 
          dist<-dist+(point[i]-rec[2*i-1])^2
   }
   dist<-sqrt(dist)
   if (dist>r1) tulos<-0 else tulos<-1

}
else{                    # rec2 is d-vector

   dista<-sqrt(sum((rec1-rec2)^2))
   if (dista>r1+r2) tulos<-0 else tulos<-1

}

}
else{   # dist.type=="recta"

if (length(rec2)==2*d){  # rec2 is 2*d vector (rectangle)

    tulos<-1
    i<-1
    while ((i<=d) && (tulos==1)){
       ala<-max(rec1[i]-r1,rec2[2*i-1])
       yla<-min(rec1[i]+r1,rec2[2*i])
       if (yla<ala) tulos<-0
       i<-i+1
    }

}
else{                    # rec2 is d-vector

    tulos<-1
    i<-1
    while ((i<=d) && (tulos==1)){
       ala<-max(rec1[i]-r1,rec2[i]-r2)
       yla<-min(rec1[i]+r1,rec2[i]+r2)
       if (yla<ala) tulos<-0
       i<-i+1
    }

}

}

return(tulos)
}






touch<-function(rec1,rec2,epsi=0.000001)
{
# Checks whether rectangles rec1, rec2 touch.
# rec1,rec2 are 2*d vectors

# Returns FALSE if intersection is empty

d<-length(rec1)/2
tulos<-TRUE
i<-1
while ((i<=d) && (tulos)){  
    ala<-max(rec1[2*i-1],rec2[2*i-1])
    yla<-min(rec1[2*i],rec2[2*i])
    if (yla+epsi<ala) tulos<-FALSE
    i<-i+1
}
return(tulos)
}




touchstep<-function(node,curroot,boundrec,child,sibling,infopointer,
low,upp,rho=0)
{
# Checks whether "node" touches some of the leafs of the branch whose
# root is "curroot". Goes through the branch starting at "curroot".
# "comprec" is associated with the "node"
# "currec" is the bounding box of "cur"
# "pointrec" is associated with "cur"

d<-length(low[1,])
comprec<-matrix(0,2*d,1)
note<-infopointer[node]   #nodefinder[infopointer[node]]
for (i in 1:d){
    comprec[2*i-1]<-low[note,i]   #index[infopointer[node],i]
    comprec[2*i]<-upp[note,i]     #index[infopointer[node],i]
}

itemnum<-length(child)
pino<-matrix(0,itemnum,1)

potetouch<-1
istouch<-0
pino[1]<-curroot
pinin<-1
while ((pinin>0) && (istouch==0)){
      cur<-pino[pinin]      #take from stack
      pinin<-pinin-1

      # create currec and pointrec
      currec<-boundrec[cur,]
      pointrec<-matrix(0,2*d,1)
      note<-infopointer[cur]   #nodefinder[infopointer[cur]]
      for (i in 1:d){
         pointrec[2*i-1]<-low[note,i] #index[infopointer[cur],i]
         pointrec[2*i]<-upp[note,i]   #index[infopointer[cur],i]
      }
      # find touches                        
      potetouch<-touchi(comprec,currec,rho) 
      istouch<-touchi(comprec,pointrec,rho)

      # put to the stack
      if (sibling[cur]>0){
            pinin<-pinin+1
            pino[pinin]<-sibling[cur]
      }
      # go to left and put right nodes to the stack
      while ((child[cur]>0) && (istouch==0) && (potetouch==1)){
            cur<-child[cur]

            # create currec and pointrec
            currec<-boundrec[cur,]
            pointrec<-matrix(0,2*d,1)
            note<-infopointer[cur]   #nodefinder[infopointer[cur]]
            for (i in 1:d){
               pointrec[2*i-1]<-low[note,i] #index[infopointer[cur],i]
               pointrec[2*i]<-upp[note,i]   #index[infopointer[cur],i]
            }
            # find touches                        
            potetouch<-touchi(comprec,currec,rho) 
            istouch<-touchi(comprec,pointrec,rho)
 
            if (sibling[cur]>0){
                 pinin<-pinin+1
                 pino[pinin]<-sibling[cur]
            }
      }
}

return(istouch)
}                                    
touchstep.tail<-function(node,curroot,boundrec,child,sibling,infopointer,
low,upp,rho,dendat,dist.type="euclid")
{
# Checks whether "node" touches some of the leafs of the branch whose
# root is "curroot". Goes through the branch starting at "curroot".
# "comprec" is associated with the "node"
# "currec" is the bounding box of "cur"
# "pointrec" is associated with "cur"

d<-length(low[1,])

note<-infopointer[node]   #nodefinder[infopointer[node]]
comprec<-dendat[note,]
r1<-rho[note]

itemnum<-length(child)
pino<-matrix(0,itemnum,1)
potetouch<-1
istouch<-0
pino[1]<-curroot
pinin<-1
while ((pinin>0) && (istouch==0)){
      cur<-pino[pinin]      #take from stack
      pinin<-pinin-1

      # create currec and pointrec
      currec<-boundrec[cur,]
      note<-infopointer[cur]   #nodefinder[infopointer[cur]]
      pointrec<-dendat[note,]
      # find touches  
      r2<-rho[note]       
      potetouch<-touchi.tail(comprec,currec,r1,dist.type=dist.type) 
      istouch<-touchi.tail(comprec,pointrec,r1,r2,dist.type=dist.type)

      # put to the stack
      if (sibling[cur]>0){
            pinin<-pinin+1
            pino[pinin]<-sibling[cur]
      }
      # go to left and put right nodes to the stack
      while ((child[cur]>0) && (istouch==0) && (potetouch==1)){
            cur<-child[cur]

            # create currec and pointrec
            currec<-boundrec[cur,]
            note<-infopointer[cur]   #nodefinder[infopointer[cur]]
            pointrec<-dendat[note,]
            # find touches                        
            r2<-rho[note]
            potetouch<-touchi.tail(comprec,currec,r1,dist.type=dist.type) 
            istouch<-touchi.tail(comprec,pointrec,r1,r2,dist.type=dist.type)
 
            if (sibling[cur]>0){
                 pinin<-pinin+1
                 pino[pinin]<-sibling[cur]
            }
      }
}

return(istouch)
}                                    
toucrec<-function(atoms,alkublokki,blokki){
#Finds which atoms touch each other
#
#items is atomnum*(2*d)-matrix
#alkublokki is an estimate to the maximum number of touches
#
#Returns links, atomnum*maxtouches-matrix
#
if (dim(t(atoms))[1]==1) m<-1 else m<-length(atoms[,1]) #m is number of atoms
len<-alkublokki
links<-matrix(NA,m,len)
maara<-matrix(0,m,1)
# merkitaan kosketukset linkit-matriisiin
i<-1
while (i<=m){
  j<-i+1
  while (j<=m){
    rec1<-atoms[i,]
    rec2<-atoms[j,]
    crit<-touch(rec1,rec2)
    if (crit){ #jos suorakaiteet koskettavat
        maari<-maara[i]+1
        maarj<-maara[j]+1
        if ((maari>len) || (maarj>len)){
            links<-blokitus2(links,blokki)
            len<-len+blokki
        }
        links[i,maari]<-j
        maara[i]<-maari
        links[j,maarj]<-i
        maara[j]<-maarj         
    }
    j<-j+1 
  }
  i<-i+1
} 
return(links)
}






treedisc<-function(lst, pcf, ngrid=NULL, r=NULL, type=NULL, lowest="dens")
{
# r is vector of radiuses, we prune shapetree "lst" so that
# its radiuses are given by r

if (lowest=="dens") lowest<-0 else lowest<-min(lst$level)

if (is.null(type)){
   if (is.null(lst$refe)) type<-"lst"
   else type<-"shape"
}

if (is.null(r)){
  if (type=="shape"){
      stepsi<-lst$maxdis/ngrid
      r<-seq(0,lst$maxdis,stepsi)
  }
  else{  #type=="lst"
      stepsi<-lst$maxdis/(ngrid+1)    
      r<-seq(lowest+stepsi,lst$maxdis-stepsi,stepsi)
  }
}

mt<-multitree(lst$parent)
child<-mt$child
sibling<-mt$sibling

d<-dim(lst$center)[1]
itemnum<-length(lst$parent)

if (is.null(pcf$step)){
    step<-matrix(0,d,1)
    for (i in 1:d) step[i]=(pcf$support[2*i]-pcf$support[2*i-1])/pcf$N[i];
    pcf$step<-step
}

################################################

parent<-matrix(NA,itemnum,1)

pino<-matrix(0,itemnum,1)
pinoparent<-matrix(0,itemnum,1)
pinorad<-matrix(0,itemnum,1)

pino[1]<-1
pinoparent[1]<-0
pinorad[1]<-1
pinin<-1
curradind<-1

while (pinin>0){ # && (curradind<=length(r))){
      cur<-pino[pinin]      #take from stack
      curpar<-pinoparent[pinin]
      curradind<-pinorad[pinin]
      pinin<-pinin-1

      # put to the stack
      if (sibling[cur]>0){
            pinin<-pinin+1
            pino[pinin]<-sibling[cur]
            pinoparent[pinin]<-curpar
            pinorad[pinin]<-curradind
      }

      note<-lst$infopointer[cur] #cur
      if (type=="lst")
         etai<-pcf$value[note]
      else{
         recci<-matrix(0,2*d,1)
         for (jj in 1:d){
            recci[2*jj-1]<-pcf$support[2*jj-1]+pcf$step[jj]*pcf$down[note,jj]
            recci[2*jj]<-pcf$support[2*jj-1]+pcf$step[jj]*pcf$high[note,jj]  
         }
         etai<-sqrt(etaisrec(lst$refe,recci))
      }

      if (curradind<=length(r)) currad<-r[curradind] else currad<-1000000
      if (etai>currad){
          parent[cur]<-curpar
          curpar<-cur
          curradind<-curradind+1
      }

      # go to left and put right nodes to the stack
      while (child[cur]>0){  # && (curradind<=length(r))){
            cur<-child[cur]

            if (sibling[cur]>0){
                 pinin<-pinin+1
                 pino[pinin]<-sibling[cur]
                 pinoparent[pinin]<-curpar
                 pinorad[pinin]<-curradind
            }
 
            note<-lst$infopointer[cur] #cur
            if (type=="lst")
                etai<-pcf$value[note]
            else{
                recci<-matrix(0,2*d,1)
                for (jj in 1:d){
                   recci[2*jj-1]<-pcf$support[2*jj-1]+pcf$step[jj]*pcf$down[note,jj]
                   recci[2*jj]<-pcf$support[2*jj-1]+pcf$step[jj]*pcf$high[note,jj]  
                }
                etai<-sqrt(etaisrec(lst$refe,recci))
            }

            if (curradind<=length(r)) currad<-r[curradind] else currad<-1000000
            if (etai>currad){
                parent[cur]<-curpar
                curpar<-cur
                curradind<-curradind+1 
            }
 
      }

}

#lst$roots<-c(1)
#lst$parent<-parent
#return(lst)

# Prune ##################################

newparent<-matrix(0,itemnum,1)
newcenter<-matrix(0,d,itemnum)
newvolume<-matrix(0,itemnum,1)
newlevel<-matrix(0,itemnum,1)
newpointer<-matrix(0,itemnum,1)
newdistcenter<-matrix(0,d,itemnum)
newproba<-matrix(0,itemnum,1)

#newparent[1]<-0
#newcenter[,1]<-lst$center[,1]
#newvolume[1]<-lst$volume[1]
#newlevel[1]<-lst$level[1]
#newpointer[1]<-1
#newdistcenter[,1]<-lst$distcenter[,1]

i<-1
newlkm<-0
while (i<=itemnum){
    if (!is.na(parent[i])){
         newlkm<-newlkm+1
         newpointer[i]<-newlkm
         if (parent[i]==0)  newparent[newlkm]<-0
         else newparent[newlkm]<-newpointer[parent[i]]
         newcenter[,newlkm]<-lst$center[,i]
         newlevel[newlkm]<-lst$level[i]
         newvolume[newlkm]<-lst$volume[i]
         newdistcenter[,newlkm]<-lst$distcenter[,i]
         newproba[newlkm]<-lst$proba[i]
    }
    i<-i+1
}

newparent<-newparent[1:newlkm]
if (newlkm<=1) newcenter<-matrix(newcenter[,1],d,1) 
else newcenter<-newcenter[,1:newlkm]
newvolume<-newvolume[1:newlkm]
newlevel<-newlevel[1:newlkm]
if (newlkm<=1) newdistcenter<-matrix(newdistcenter[,1],d,1) 
else newdistcenter<-newdistcenter[,1:newlkm]
newproba<-newproba[1:newlkm]
newpointer<-newpointer[1:newlkm]

return(list(parent=newparent,level=newlevel,volume=newvolume,center=newcenter,
distcenter=newdistcenter,  #branchradius=newbranchradius,
proba=newproba,
refe=lst$refe,bary=lst$bary,root=1,infopointer=newpointer))

}   

tree.segme<-function(tt,paletti=NULL,pcf=NULL)
{

if (is.null(paletti))
 paletti<-c("red","blue","green",
 "orange","navy","darkgreen",
 "orchid","aquamarine","turquoise",
 "pink","violet","magenta","chocolate","cyan",
 colors()[50:657],colors()[50:657])

colors<-colobary(tt$parent,paletti)
if (is.null(pcf)) segme<-colors
else{
  lenni<-length(pcf$value)
  segme<-matrix(0,lenni,1)
}
for (i in 1:length(colors)) segme[tt$infopointer[i]]<-colors[i]

return(segme)
}






vectomatch<-function(vec1,vec2)
{

d<-dim(vec1)[2]
prenum<-dim(vec1)[1]
curnum<-dim(vec2)[1]
parento<-matrix(0,curnum,1)

smallernum<-min(prenum,curnum)
greaternum<-max(prenum,curnum)

dista<-matrix(NA,smallernum,greaternum)
for (ap in 1:smallernum){
    for (be in 1:greaternum){
           if (d==1){
               if (prenum<=curnum){
               precenter<-vec1[ap]
               curcenter<-vec2[be]
               }
               else{
               precenter<-vec2[ap]
               curcenter<-vec1[be]
               }
           }
           else{
               if (prenum<=curnum){
               precenter<-vec1[ap,]
               curcenter<-vec2[be,]
               }
               else{
               precenter<-vec2[ap,]
               curcenter<-vec1[be,]
               }
           }
           dista[ap,be]<-etais(curcenter,precenter)
    }
}

match<-matrix(0,smallernum,1)  #for each mode the best match
findtie<-TRUE

# find the best match for all and check whether there are ties
match<-matrix(0,smallernum,1)
for (bm in 1:smallernum){
      minimi<-min(dista[bm,],na.rm=TRUE)
      match[bm]<-which(minimi==dista[bm,])[1]
}
findtie<-FALSE
bm<-1
while ((bm<=smallernum) && (findtie==FALSE)){
         koe<-match[bm]
         bm2<-bm+1
         while (bm2<=smallernum){
            if (koe==match[bm2]){
                  findtie<-TRUE
            }
            bm2<-bm2+1
         }
         bm<-bm+1
}
    
onkayty<-FALSE
tiematch<-matrix(0,smallernum,1)

while (findtie){

      onkayty<-TRUE
      
      # find the best match for all
      bestmatch<-matrix(0,smallernum,1)
      for (bm in 1:smallernum){
          allna<-TRUE
          am<-1
          while ((am<=greaternum) && (allna)){
             if (!is.na(dista[bm,am])) allna<-FALSE
             am<-am+1
          }
          if (!(allna)){
             minimi<-min(dista[bm,],na.rm=TRUE)
             bestmatch[bm]<-which(minimi==dista[bm,])[1]
          }
          else bestmatch[bm]<-tiematch[bm]
      }

      # find the first tie
      findtie<-FALSE

      tieset<-matrix(0,smallernum,1)
      bm<-1
      while ((bm<=smallernum) && (findtie==FALSE)){
         koe<-bestmatch[bm]
         bm2<-bm+1
         while (bm2<=smallernum){
            if (koe==bestmatch[bm2]){
                  findtie<-TRUE
                  tieset[bm]<-1
                  tieset[bm2]<-1
            }
            bm2<-bm2+1
         }
         bm<-bm+1
      }

      # solve the first tie
      if (findtie==TRUE){
         numofties<-sum(tieset)
         kavelija<-0
         tiepointer<-matrix(0,numofties,1) 
         # find the second best
         secondbest<-matrix(0,smallernum,1)
         for (bm in 1:smallernum){
            if (tieset[bm]==1){
               redudista<-dista[bm,]
               redudista[bestmatch[bm]]<-NA
               minimi<-min(redudista,na.rm=TRUE)
               secondbest[bm]<-which(minimi==redudista)[1]

               kavelija<-kavelija+1
               tiepointer[kavelija]<-bm
            }
         }
         # try different combinations       
         # try all subsets of size 2 from the set of ties
         numofsubsets<-choose(numofties,2)
            #gamma(numofties+1)/gamma(numofties-2+1)
         valuelist<-matrix(0,numofsubsets,1)
         vinnerlist<-matrix(0,numofsubsets,1)
         matchlist<-matrix(0,numofsubsets,1)
         runneri<-1
         eka<-1
         while (eka<=numofties){
            ekapo<-tiepointer[eka]
            toka<-eka+1
            while (toka<=numofties){
               tokapo<-tiepointer[toka]
               # try combinations for this subset (there are 2)
               # 1st combination
               fvinner<-ekapo
               fvinnermatch<-bestmatch[fvinner]
               floser<-tokapo
               flosermatch<-secondbest[floser]
               fvalue<-dista[fvinner,fvinnermatch]+dista[floser,flosermatch]
                # 2nd combination
               svinner<-tokapo
               svinnermatch<-bestmatch[svinner]
               sloser<-ekapo
               slosermatch<-secondbest[sloser]
               svalue<-dista[svinner,svinnermatch]+dista[sloser,slosermatch]
               # tournament
               if (fvalue<svalue){
                   valuelist[runneri]<-fvalue
                   vinnerlist[runneri]<-fvinner
                   matchlist[runneri]<-fvinnermatch
               }
               else{ 
                   valuelist[runneri]<-svalue
                   vinnerlist[runneri]<-svinner
                   matchlist[runneri]<-svinnermatch
               }
               runneri<-runneri+1 
               # 
               toka<-toka+1
            }
            eka<-eka+1
         }
         minimi<-min(valuelist,na.rm=TRUE)
         bestsub<-which(minimi==valuelist)[1]
         vinnerson<-vinnerlist[bestsub]
         matcherson<-matchlist[bestsub]

         tiematch[vinnerson]<-matcherson
         dista[vinnerson,]<-NA
         dista[,matcherson]<-NA

      }

}  #while (findtie)

if (onkayty){  #there was one tie
          
          for (sepo in 1:smallernum){
               if (tiematch[sepo]!=0) match[sepo]<-tiematch[sepo]
               else match[sepo]<-bestmatch[sepo]
          }
}

newnode<-matrix(0,curnum,1)
if (prenum>curnum) parento<-match
else{
    for (i in 1:prenum){   #kaannetaan linkit
        linko<-match[i]
        parento[linko]<-i
    }    
    for (j in 1:curnum){
        if (parento[j]==0){   #jos ei linkkia, haetaan lahin vanhemmaksi
             newnode[j]<-1    #we label the rest-labels
             distvec<-dista[,j]  #sarake antaa etaisyyden
             minimi<-min(distvec,na.rm=TRUE)
             parento[j]<-which(minimi==distvec)[1]
        }
    }
}

return(list(parent=parento,newnode=newnode))
}



















volball<-function(r,d){ return(r^d*pi^(d/2)/gamma(d/2+1)) }

weightsit<-function(n,h,katka=4)
{
#normvakio<-(sqrt(2*pi)*h)^{-1}
resu<-matrix(0,n,1)
zumma<-0
for (i in 1:n){
    eta<-(n-i)
    if (eta/h>katka) tulos<-0 else tulos<-exp(-eta^2/(2*h^2))#*normvakio
    resu[i]<-tulos
    zumma<-zumma+tulos
}

resu<-resu/zumma

return(resu)
}



.First.lib <- function(lib, pkg) library.dynam("denpro", pkg, lib)