#' Frequency distribution of multivariate numeric data with case weight
#'
#' @param x numeric vector or column vector
#' @param weights case weight
#' @param npoints # of mid-points for each variable
#' @param min minimum value of mid-points
#' @param max maximum value of mid-points \cr
#'  For the multivariate x, (npoints, min, max) can be vectors \cr
#'  specifying different numbers for each variable.
#' @param prob = 1 to return relative frequency in stead of frequency
#' @param rev = 1 to change the last element of x first.
#' @param omitmiss = 1 to omit the missing grids
#' @param midpoints a list of the vectors of predefied mid-point values \cr
#'  For the multivariate x, midpoints defines the midpoints of
#'  each variable,  not their Cartesian products.
#' @param class = 1 to  output the classification of each observation
#' to the mid-point.
#' @param title tile to be used in plot
#' @param maxf max value of frequency for plot
#' @param wid Format of mid-point value (wid.dig)
#' @param dig Format of mid-point value (wid.dig)
#' @param digits Format for mid-points
#' @param print = 1 to print result
#' @param plot = 1 to plot historgam
#' @return A list consisting of \cr
#'   midpoints=  list of midpoints \cr
#'   midpoints1= list of midpoints with lost values \cr
#'   midpindex   cartesian product of midpoints number \cr
#'   grid=       cartesian product of midpoints \cr
#'               grid[,j]=midpoints[[j]][midpindex[,j]], j=1,2,...,nvar \cr
#'   freq=       column vector of frequency at midpoints \cr
#'   breaks=     breaks associated with the midpoints \cr
#'   class=      classification of each obs into the midpoints if class=1. \cr
#'   classc=     classification of each obs into the midpoints class
#'    if class=1 . \cr
#'   nobs= sum of weights\cr
#' @details
#'   (npoints, min, max)  defines the mid-points. \cr
#'    If min or max is NULL, min(x) and max(x) will be used. \cr
#'    midpoints has priority over (npoints, min, max).\cr
#' The out of range observations,  that is, those x satisfying \cr
#'  x < midpoints[1]     or   midpoints[npoints] < x \cr
#'  will be be included in midpoints[1] and midpoints[npoints], resp. \cr
#' \cr
#' Try this to see how the obs on the border are classified. \cr
#'    xx=c(1,2,3,4,5,6,7) \cr
#'    brks=c(0,2,4,6,8) \cr
#'    cc=cut(xx,brks) \cr
#'
#' @examples
#' set.seed(1701)
#' n <- 1000
#' X <- matrix(rnorm(2*n),n,2)
#' res <- freqdist( X, npoints=7,min=-3,max=3, print=1, weights=1, plot=1)
#'
#' X <- expand.grid(seq(-3,3),seq(-3,3))
#' weight <- round(n*exp(-0.5*rowSums(X^2)))
#' res1 <- freqdist( X, weight, npoints=c(7,5),min=-3,max=3, print=1, plot=1)
#' res2 <- freqdist( X, weight, npoints=c(7,5),min=-3,max=3, print=1, class=1)
#' str(res2)
#'
#' @export
#'

freqdist <- function( x, weights=1, npoints=NULL, min=NULL, max=NULL, prob=0
                      , wid=6, dig=1, maxf=NULL, rev=0, class=0, omitmiss=0
                      , midpoints=NULL, title=NULL, digits=3, print=0, plot=0 ){
 # freq dist of x using midpoints
 # Shin-ichi Mayekawa
 # 20121026
 # out-of-range observations: 121219
 # return freq: 130218
 # weights with xtabs: 130218
 # multivariate version: 130218
 # revised: 20140221,26
 # unlist midpoints when nvar=1: 140417
 # title as an arg: 140417
 # bugfix: 20140524,25
 # recover lost midpoints after cut: 20140525
 # all(wieghts==1): 20140812 dnc
 # bugfix: 20140812 dnc
 # matrix weights: 20140813,14,15 dnc
 # rev: 20140816
 # class and omitmiss: 20140816
 # error check: 20150608
 # bugfix: 20150822
 # output classc: 20241212
 #
 # Args:
 #
 #    x            a variable to be tabulated
 #    weights      assosiated weight vector or 1
 #                 Can be a matrix of multiple columns.
 #
 #    rev         = 1 to change the last element of x first.
 #    omitmiss    = 1 to omit the missing grids
 #
 #    (npoints, min, max)    definition of midpoints
 #                 If min or max is NULL, min(x) and max(x) will be used.
 #                 For the multivariate x, (npoints, min, max) can be vectors.
 #
 #     midpoints   list of midpoints of each column of x
 #                 If midpoints is NULL, (npoints, min, max) will be used.
 #
 #                 For the multivariate x, midpoints defines the midpoints
 #                 of each variable,  not their cartesian products.
 #
 #     prob      = 1 to return the relative frequency, not raw frequency
 #
 #     maxf      = maximum value of the vertical axis for univariate x
 #
 #     (wid, dig) formatC for the midpoints in plot
 #
 #     title      plot title
 #
 #     class     = 1 to output classification
 #
 #
 # Values:
 #
 #   midpoints   list of midpoints
 #   midpoints1  list of actual midpoints (lost points excluded)
 #   midpindex   cartesian product of midpoints number
 #   grid        cartesian product of midpoints
 #               grid[,j]=midpoints[[j]][midpindex[,j]], j=1,2,...,nvar
 #   freq        matrix of frequency at grid
 #   breaks      breaks associated with the midpoints
 #   class       classification of each obs into the grid if class=1
 #
 #
 # Note:
 #  The out of range observations,  that is, those x satisfying
 #     x < midpoints[1]     or   midpoints[npoints] < x
 #  will be be included in midpoints[1] and midpoints[npoints], resp.
 #
 #
 #  When rev=1, native contour does not produce correct plot
 #  because freq is not in the order of outer product of midpoints.
 #  Use the levelplot function of lattice package as:
 #
 #   res <- freqdist( ........ )
 #   levelplot( res$freq ~ res$grid[,1]*res$grid[,2], contour=1, cut=7
 #            , region=FALSE )
 #
 #
 # Needs:
 #
 #    vartype
 #
 #
 
 
 # check if x is numeric
 if( any(vartype(x) != "numeric") ){
  cat("\n\nerror1:(freqdist) variables must be numeric.\n\n")
  return(NULL)
 }
 
 # length
 if( is.vector(x) ) x=matrix(x,,1)
 n=nrow(x)
 nvar=ncol(x)
 if( is.null(rownames(x)) ) rownames(x)=paste("r",1:n,sep="")
 xname=colnames(x)
 if( is.null(xname) ) xname=paste("var",1:nvar,sep="")
 
 
 # univariate
 if( nvar == 1 ){
  res=freqdist1( x=x, weights=weights, npoints=npoints
                 , min=min, max=max, prob=prob
                 , wid=wid, dig=dig, maxf=maxf
                 , midpoints=midpoints, title=title
                 , digits=digits, print=print, plot=plot )
  return( res )
 }
 
 # define midpoints
 if( !is.null(midpoints) ){
  # midpoints given
  if( !is.list(midpoints) ){
   midpoints=list(midpoints)
   midpoints=rep(midpoints,nvar)
  }
  else if( length(midpoints) == 1 ) midpoints=rep(midpoints,nvar)
  npoints=sapply(midpoints,function(x) sum(!is.na(x)))
  min=sapply(midpoints,min); max=sapply(midpoints,max)
 }
 else{
  # midpoints not given
  if( is.null(min) ) min=apply(x,2,min)
  else if( length(min) == 1 ) min=rep(min,nvar)
  if( is.null(max) ) max=apply(x,2,max)
  else if( length(max) == 1 ) max=rep(max,nvar)
  if( length(npoints) == 1 ) npoints=rep(npoints,nvar)
  midpoints=NULL
  for( j in 1:nvar ){
   mdpj=seq(min[j],max[j],length.out=npoints[j])
   midpoints=append(midpoints, list( mdpj ))
  }
 }
 
 # breaks
 breaks=NULL
 for( j in 1:nvar ){
  breaksj=c(midpoints[[j]][2:npoints[j]],midpoints[[j]][npoints[j]]+1)
  breaksj=(breaksj+midpoints[[j]])/2
  breaksj[npoints[j]]=max(max(breaksj),max(x[,j]))+0.5
  breaksj=c(min(min(breaksj),min(x[,j]))-0.5,breaksj)
  breaks=append(breaks,list(unique(breaksj)))
 }
 
 # weights
 if( is.null(weights) ) weights=matrix(1,n,1)
 else if( length(weights) == 1 ) weights=matrix(1,n,1)
 else if( is.matrix(weights) ){
  if( nrow(weights) != n ){
   cat("\nerror(freqdist): invalid weight matrix.","\n")
   return()
  }
 }
 else if( is.vector(weights) ){
  if( length(weights) != n ){
   cat("\nerror(freqdist): invalid weight vector.","\n")
   return()
  }
  else{
   weights=matrix(weights,,1)
  }
 }
 nobs=colSums(weights)
 nf=ncol(weights)
 wname=colnames(weights)
 if( is.null(wname) ) wname=paste("freq",1:nf,sep="")
 
 
 if( print > 0 ){
  cat("\nFrequency Distribution\n")
  if( !is.null(title) ) print(title)
  Print(nvar,n,nf,nobs, rev, omitmiss, class)
  Print(npoints,min,max)
  
  cat("\n")
  for( j in 1:nvar ){
   left=breaks[[j]][-npoints[j]]
   left[1]=NA
   left[npoints[j]]=breaks[[j]][npoints[j]]
   right=breaks[[j]][-1]
   right[npoints[j]]=NA
   left=formatC(left, width=wid, digits=dig, format="f")
   right=formatC(right, width=wid, digits=dig, format="f")
   mp=formatC(midpoints[[j]], width=wid, digits=dig, format="f")
   char=cbind(left, "  <  ", mp, "  <=  ", right)
   char=rbind(
    c("left brk","   "," middp","    ","right brk"), char)
   char=matrix(apply(char,1,paste,collapse="  "),,1)
   char=format(char,justify="left")  # centre
   cat("\nCategorization of Variable",j,"\n")
   write.table(char, row.names=FALSE, col.names=FALSE, quote=FALSE)
  }
 }
 
 
 # categorize the observations  by cutting them at the break points
 c=NULL      # list of categorical values correspoinding each obs
 cc=NULL     #  list of category numbers correspoinding each obs
 lab=NULL    # list of formatted (rounded) values of midpoints
 # to be used as the names
 lost=NULL   # list of lost midpoints
 midp1=NULL  # actual midpoints: lost ones removed
 for( j in 1:nvar ){
  labelsj=format(midpoints[[j]],digits=digits)
  cj=cut( x[,j], breaks=breaks[[j]]
          , labels=labelsj
          , include.lowest=1 )
  # Print(j,cj,unique(cj),unique(as.numeric(cj)))
  
  # lost midpoints
  ucj=unique(as.numeric(cj))
  lostj=setdiff( 1:npoints[j], ucj )
  # Print(j,ucj,lostj)
  
  # category numbers
  cc=append(cc,list(unclass(cj)))
  
  # use true value of midpoints as the categorized value, not the label.
  cj=midpoints[[j]][cj]
  c=append(c,list(cj))
  lab=append(lab,list(labelsj))
  lost=append(lost,list(lostj))
  midp1=append(midp1,list(midpoints[[j]][sort(ucj)]))
 }
 
 # convert c to matrix assuming equal lengths
 # c=sapply(c, '[', 1:max(sapply(c, length)))
 c=sapply(c, unlist)
 cc=sapply(cc, unlist)
 # Print("****\n", lost,c)
 
 # append obs corresponding to the lost midpoints with zero weight
 for( j in 1:nvar ){
  lostj=lost[[j]]
  
  if( length(lostj) > 0 ){
   cj=matrix(sapply(midpoints,"[[",1),length(lostj),nvar, byrow=1)
   cj[,j]=midpoints[[j]][lostj]
   c=rbind(c,cj)
   weights=c(weights,rep(0,length(lostj)))
   cj=matrix(1, length(lostj), nvar, byrow=1)
   cj[,j]=(1:length(midpoints[[j]]))[lostj]
   cc=rbind(cc,cj)
  }
 }
 
 nlost=0
 if( nrow(c) > n ){
  nlost=nrow(c)-n
  rownames(c)=c(rownames(x),rep("dummy",nrow(c)-n))
  rownames(cc)=c(rownames(x),rep("dummy",nrow(c)-n))
  if( print >= 1 ){
   cat("\n")
   cat(" Following ", nlost, " dummy observations with 0 weights are added\n")
   cat("   in order to make the grid complete.\n")
   Print(c[(n+1):nrow(c),,drop=0], cc[(n+1):nrow(c),,drop=0])
   Print(weights[(n+1):nrow(c)])
   cat("Lost Categories\n")
   for( j in 1:nvar ){
    if( length(lost[[j]]) > 0 ){
     cat(" variable",j," categories:", lost[[j]], "\n")
    }
   }
  }
 }
 
 
 # freq dist with weights as:
 #  f=xtabs(formula = weights ~ c[[1]] + c[[2]], drop.unused.levels = 0)
 #  above f will be the npoints[1] x npoints[2] matrix.
 model="weights ~ c[,1]"
 for( j in 2:nvar ) model=paste(model,"+ c[,",j,"]", sep="")
 code=paste("f=xtabs( ", model, ", drop.unused.levels=FALSE )", sep=" ")
 eval(parse(text=code))
 
 
 # check if all the midpoints are used
 namesf=dimnames(f) # This is the formatted value of c by xtabs.
 if( nf > 1 ) namesf=namesf[-(nf+1)]
 # Print(namesf,lab,midp1)
 if( length(namesf) != length(lab) ){
  cat("\nwarning1:(freqdist) Some of the midpoints values are missing.")
  cat("\n Don't know why????\n")
 }
 
 # generate grid of midpoints
 if( nf == 1 ) dimf=dim(f)
 else dimf=dim(f)[-(nvar+1)] # 20140815
 midpindex=as.matrix( expand.grid(lapply(dimf,function(a) seq(1:a))) )
 grid=midpindex
 for( j in 1:nvar ){
  grid[,j]=midpoints[[j]][midpindex[,j]]
 }
 colnames(midpindex)=xname
 colnames(grid)=xname
 #Print(midpindex,grid,f)
 
 # convert the result of xtabs into a matrix
 dim(f)=c(prod(dimf),nf)
 f=unclass(as.matrix(f)) # removing the table attribute
 colnames(f)=wname
 # f=matrix(as.numeric(f),,1)
 gridc=expand.grid( lab )
 gc=apply(gridc,1,paste,collapse=":")
 rownames(f)=gc
 #Print(gridc,gc,f)
 
 
 if( all(colSums(f) == nobs) ) error=0
 else{
  error=1
  cat("\n\nerror1(freqdist): Sum of freq does not equal to n. \n\n")
 }
 
 # convert to prob
 if( prob == 1 ){
  if( nf == 1 ) f=f/nobs
  else f=t(t(f)/nobs)
 }
 
 if( plot > 0  &  nvar == 2 ){
  #library(lattice)
  if( is.null(title) ) title="Data"
  for( j in 1:nf ){
   if( nf == 1 ) ff=f  else ff=f[,j]
   # Below does not produce plot here byt does it when executed outside.
   # levelplot( ff~grid[,1]*grid[,2], contour=1, cut=7, region=FALSE )
   contour( midpoints[[1]], midpoints[[2]], matrix(ff,length(midpoints[[1]]))
            , main=title )
  }
 } # end of plot
 
 # omit missing cells
 if( omitmiss == 1 ){
  if( nf == 1 ) locobs=which( f != 0 ) else locobs=which( apply(f,1,sum) != 0 )
  if( nf == 1 ) f=f[locobs] else f=f[locobs,]
  grid=grid[locobs,]
  midpindex=midpindex[locobs,]
  c=c[1:(n-nlost),]
  cc=cc[1:(n-nlost),]
 }
 
 # reverse order
 if( rev == 1 ){
  code="od=order( grid[,1]"
  for( j in 2:nvar ) code=paste(code,", grid[,", j, "]", sep="")
  code=paste(code," )")
  eval(parse(text=code))
  grid=grid[od,]
  midpindex=midpindex[od,]
  if( nf == 1 ) f=f[od] else f=f[od,]
 }
 
 if( print > 0 ){
  cat("\nFrequency Distribution\n")
  Print(f, midpindex, grid)
 }
 
 if( class == 1 )
  return( list( midpoints=midpoints, midpoints1=midp1
                , midpindex=midpindex, grid=grid, freq=f, breaks=breaks
                , nobs=nobs, prob=prob, error=error, rev=rev
                , omitmiss=omitmiss, class=c, classc=cc ) )
 else
  return( list( midpoints=midpoints, midpoints1=midp1
                , midpindex=midpindex, grid=grid, freq=f, breaks=breaks
                , nobs=nobs, prob=prob, error=error, rev=rev
                , omitmiss=omitmiss ) )
 
} # end of freqdist


