#' Joint Frequency Distribution of Discrete Variables
#'
#'
#' @param X Input multivariate discrete data
#' @param weight weight vector or 1
#' @param omitmiss = 0 to return the cartesian product of
#' unique values of each column of X.
#' @param sort = 1 to sort so that the last column changes first. \cr
#' = 2 to sort by frequency in ascending order \cr
#' = 3 to sort by frequency in descending order \cr
#'
#' @details
#' Calculates the frequency of the unique rows of X matrix. \cr
#' Note, however, the order of the rows are different from
#' the reslt of unique(X) which does not sort the result. \cr
#' If sort=0, the first column changes first, otherwise, the last
#' column changes first.
#'
#' @return
#' A list of: \cr
#' Xu An object consisting of the (sorted) unique rows of X \cr
#' f  Assosiated frequency vector
#'
#' @examples
#' # numeric varaibles
#' set.seed(1701)
#' X <- matrix(sample(0:1,50,replace=1),25)
#' X <- cbind(X,matrix(sample(1:2,50,replace=1),25))
#' X <- rbind(X,matrix(c(0,1,0,1),5,4,byrow=1))
#' colnames(X) <- paste("ccc",1:4,sep="")
#' res <- jfreq( X )
#' Print( res$Xu, res$f )
#'
#' # sort so that the last column changes first
#' res1 <- jfreq( X, sort=1 )
#' Print( res1$Xu, res1$f )
#'
#' # sort by frequency
#' res1 <- jfreq( X, sort=3 )
#' Print( res1$Xu, res1$f )
#'
#' # mixed variable types in a data.frame
#' Y <- as.data.frame(X)
#' Y[,2] <- letters[Y[,2]+1]
#' res2 <- jfreq( Y )
#' Print( res2$Xu, res2$f )
#'
#' @export
#'

jfreq <- function( X, weight=NULL, omitmiss=1, sort=0 ){
 # joint frequency
 # Shin-ichi Mayekawa
 # 20161106c
 # sort: 20161116
 # bugfix: 20161202
 # sort by freq: 20170917
 #

 # error
 if( length(dim(X)) > 2 ){
  cat("\nerror1(jfreq): Array object cannot be handled.\n\n")
  return()
 }

 # num or char
 vt=vartype(X)

 # const
 mode="df"
 if( is.matrix(X) | is.data.frame(X) ){
  cn=colnames(X)
  nvar=ncol(X)
  if( is.matrix(X) ){
   mode="mat"
   vt=rep(vt,nvar)
  }
 }
 else{
  cn=NULL
  nvar=1
  X=matrix(X,,1)
  mode="vec"
 }

 #  f=xtabs(formula = weights ~ X[,1] + X[,2] + ..., drop.unused.levels = 0)
 if( is.null(weight) ) wt=""
 else wt="weight"
 model=paste( wt," ~ X[,1]", sep="" )
 if( nvar > 1 ){
  for( j in 2:nvar ) model=paste(model,"+ X[,",j,"]", sep="")
 }
 code=paste("f=xtabs( ", model, ", drop.unused.levels=FALSE )", sep=" ")
 eval(parse(text=code))

 # analyze the result of xtabs
 namesf=dimnames(f) # This is the formatted value of X by xtabs.
 dimf=dim(f)
 midpindex=as.matrix( expand.grid(lapply(dimf,function(a) seq(1:a))) )
 dim(f)=prod(dimf)
 f=unclass(as.matrix(f)) # removing the table attribute

 if( omitmiss ){
  loc=which( f > 0 )
  f=f[loc]
  midpindex=midpindex[loc,,drop=0]
 }

 # Print(namesf)
 # mm=mapply( function(a,i){ a[midpindex[,i]] }, namesf, 1:nvar, SIMPLIFY=1 )
 # Print(mm)

 # values as character
 Xu=as.data.frame(
  mapply( function(a,i){ a[midpindex[,i]] }, namesf, 1:nvar, SIMPLIFY=1 )
  , stringsAsFactors=0  )
 colnames(Xu)=cn

 # convert back to the original variable type
 for( j in 1:nvar ){
  if( vt[j] == "numeric" ) Xu[,j]=as.numeric(Xu[,j])
 }

 # sort
 if( sort > 0 ){
  if( sort == 1 ){
   # sort so that the last col changes first
   Xu <- sortit( data.frame( Xu, f, stringsAsFactors=0 ), cols=1:nvar )
  }
  else if( sort == 2 ){
   Xu <- sortit( data.frame( Xu, f, stringsAsFactors=0 ), cols=nvar+1 )
  }
  else if( sort == 3 ){
   Xu <- sortit( data.frame( Xu, f, stringsAsFactors=0 ), cols=-(nvar+1) )
  }
  f=Xu[,nvar+1]
  Xu=Xu[,1:nvar]
 }

 # remove rownames
 rownames(Xu)=NULL

 # back to original mode
 if( mode == "vec" ){
  Xu=as.vector(Xu)
 }
 else if( mode == "mat" ){
  Xu=as.matrix(Xu)
 }

 return( list( Xu=Xu, f=f ) )

} # end of jfreq






#' Merge Tables or Frequency Distributions of the form (score, freq)
#'
#' @param ... tables, matrices or data.frames containing frequency distribution
#' @param omitmiss = 1 to remove zero-frequency cells
#'
#' @details
#' Each of ... can be a class table object created by native table or xtabs,
#' or a data.frame or matrix containing the level-index and frequency. \cr
#' Each of ... should have the same # of factors to be tabulated.
#'
#'
#' @examples
#'
#' set.seed(1701)
#' x <- sample(1:8,10,replace=1); x <- c(x,c(1,1,7)); xc <- paste("x",x,sep="")
#' y <- sample(0:9,10,replace=1); y <- c(y,c(5,5,0)); yc <- paste("y",y,sep="")
#'
#' # univariate example
#' rest11 <- table( x )
#' rest12 <- rest11[-c(1,3)]
#' resm <- merge_tables( rest11, rest12 )
#' plot_freqdist( resm )
#'
#' # bivariate example
#' rest2 <- table( x, y )
#' fd21 <- table2freqdist( rest2, omitmiss=1, index=1 )
#' fd22 <- fd21[-c(1,10),]
#' merge_tables( rest2, fd21, fd22, omitmiss=1 )
#'
#' @return
#' A frequency distribution of the form (x,freq)
#'
#' @export
#'

merge_tables <- function( ..., omitmiss=0 ){
 # merge several frequency distributions
 # Shin-ichi Mayekawa
 # 20160729,0801,02,03
 # pat=2 in is.number: 20171026
 # bugfix for the condition has length > 1: 20220612 
 #

 # analyse ...
 name=name <- as.character(substitute(list(...)))[-1L]
 val=list(...)
 locnull=which(unlist(lapply(val,is.null)))
 if( length(locnull) > 0 ){
  name=name[-locnull]
  val=val[-locnull]
 }
 narg=length(val)

 # convert the input to freq dist format
 nf0=numeric(narg)
 for( i in 1:narg ){
   # below if is fixed by adding [1] to class.  20220612
   if( class(val[[i]])[1] %in% c("table","xtab") ){
   # Print("*****",i,val[[i]])
   val[[i]]=table2freqdist( val[[i]], omitmiss=omitmiss, index=1 )
   # Print("**",i,val[[i]],colnames(val[[i]]))
  }
  nfi=ncol(val[[i]])
  if( is.matrix(val[[i]]) ){
   # Print(colnames(val[[i]]))
   val[[i]]=as.data.frame(val[[i]], stringsAsFactors=0)
   if( nfi == 1 ) colnames(val[[i]])[1:(nfi-1)]=rep("",nfi-1)
   # Print(colnames(val[[i]]))
  }
  nf0[i]=nfi
  colnames(val[[i]])[nf0[i]]="freq"
 }

 if( any(nf0 != nf0[1]) ){
  cat("\nerror1(merge_tables): The sizes of input do not conform.\n")
  Print(nf0)
  return()
 }

  if( narg >= 3 ){
  # recursive call to merge_tables
  res=Recall( val[[1]], val[[2]], omitmiss=omitmiss )
  for( i in 3:narg ){
   # Print(i, res, val[[i]])
   res=Recall( res, val[[i]], omitmiss=omitmiss )
  }

  return( res )
 }


 ########################################################################
 # simple case starts here.
 ########################################################################
 fd1=val[[1]]; fd2=val[[2]]

 # Print(fd1,fd2,val[[1]],val[[2]])
 if( ncol(fd1) != ncol(fd2) ){
  cat("\nerror1(merge_tables): The sizes of input do not conform.\n")
  return()
 }
 nf=ncol(fd1)-1


 if( nf == 1 ){
  fd12=rbind(fd1,fd2, stringsAsFactors=0)
  # Print(fd12)
  fd=xtabs(fd12[,2]~fd12[,1])
  nam=as.character(fd12[,1])
  if( is.number(nam, pat=2) ) nam=as.numeric(nam)
  fd=data.frame(unique(nam),unclass(fd), stringsAsFactors=0)
  colnames(fd)=c(colnames(fd1)[1],"freq")
  rownames(fd)=NULL
  od=fd[,]
 }
 else{
  fd=merge( fd1, fd2, by=1:nf, all=TRUE )
  fdm1=fd[,1:nf]
  fdm2=fd[,(nf+1):ncol(fd)]
  fdm2[is.na(fdm2)]=0
  fd=data.frame(fdm1,rowSums(fdm2), stringsAsFactors=0)
  colnames(fd)[nf+1]="freq"
 }

 return( fd )

} # end of merge_tables






#' Convert an output of table or xtabs to a simple frequency table format
#'
#' @param tab An output of native table or xtabs function.
#' @param omitmiss = 1 to exclude the zero-freq cells.
#' @param index = 0 to output no level indices
#' @param pat  argument to is.number function.
#' @param sort = 0 not to sort the result
#'
#' @return
#' When index == 1 and there are nf factors(variables) to be tabulated, \cr
#' the output is a matrix or data.frame: \cr
#' the first nf columns of which consist of the level indices,
#' and the nf+1st column contains the frequency count. \cr
#'
#' If the levels are numeric, a matrix will be returned. Otherwise,
#' a data.frame. \cr
#' In both cases
#'   \code{rownames(fd)} contains the combinations of the level names.
#'
#' @examples
#' set.seed(1701)
#' x <- sample(1:8,10,replace=1); x <- c(x,c(1,1,7)); xc <- paste("x",x,sep="")
#' y <- sample(0:9,10,replace=1); y <- c(y,c(5,5,0)); yc <- paste("y",y,sep="")
#' z <- sample(5:9,10,replace=1); z <- c(z,c(5,5,9)); zc <- paste("z",z,sep="")
#'
#' rest1 <- table( x )
#' rest2 <- table( x, y )
#' rest3 <- table( xc,y,z )
#' restx3 <- xtabs( ~xc+yc+z )
#'
#' table2freqdist( rest1 )
#' table2freqdist( rest2 )
#' table2freqdist( rest3, omitmiss=1 )
#' table2freqdist( restx3, omitmiss=1, index=0 )
#'
#' tab2 <- table( x=sample( letters[1:5], 20, replace=1)
#'              , sample(letters[6:8], 20, replace=1) )
#' table2freqdist( tab2 )
#'
#' @export
#'

table2freqdist <- function( tab, omitmiss=0, index=1, pat=2, sort=1 ){
 # convert the output of table or xtabs to simple format
 # Shin-ichi Mayekawa
 # 20160731,0801,02,03
 # bugfix: 20171026
 # pat=1 -> pat=2: 20171026
 # sort: 20171026
 # varnames: 20180812
 #

 if( !any( class(tab) %in% c("xtabs", "table") ) ){
  cat("\n Input must be of class 'xtabs' or 'table'. \n")
  return()
 }

 if( index != 1 ) index=0

 # main body
 fd=matrix(tab,,1)
 dimnames=dimnames(tab)
 nf=length(dimnames)
 cnames=names(dimnames)
 loc=which(cnames == "")
 cnames[loc]=paste("v_",1:nf,sep="")[loc]

 names2=expand.grid(dimnames, stringsAsFactors=0)
 rownames(fd)=apply( names2, 1, paste, collapse=":" )
 colnames(fd)="freq"
 colnames(names2)=cnames

 if( index > 0 ){
  if( all(is.number(dimnames, pat=pat)==1) ){
   names2=matrix(t( apply( names2, 1, as.numeric ) ),,nf)
   colnames(names2)=cnames
   fd=cbind( names2, fd )
   # fd is a matrix
  }
  else{
   fd=data.frame( names2, fd, stringsAsFactors=0 )
   # colnames(fd)[1:nf]=""           # 20180812
   # above fd is a data.frame
  }
 }

 if( omitmiss == 1 ){
  fd=fd[fd[,nf*index+1] > 0,,drop=0]
 }

 # sort
 if( sort == 1 ){
  if( index == 1 ) fd=sortit( fd, cols=1:nf )
  else{
   od=order(rownames(fd))
   rn=rownames(fd)[od]
   fd=fd[od,,drop=0]
  }
 }

 return( fd )

} # table2freqdist




#' Plot Univariate Tables or Frequency Distributions of the form (score, freq)
#'
#' @param fd tables, matrices or data.frames containing
#'  univariate frequency distribution (midpoint,freq).
#' @param weight A vector of weights associated with fd[,1] \cr
#' @param main A string to be used as the main title.
#' @param numeric = 0 to plot w/o filling in the missing value of fd[,1].
#' @param space an option to be passed to native barplot (default=0) \cr
#' the value of which specifies the width of the spaces between bars.
#' @param las an option to be passed to native to barplot (default=2) \cr
#' = 0 to rotate h, = 1 to rotate none, = 2 to rotate x, = 3 to rotate both.
#' @param title An alias for main.
#' @param ... additional parameters to barplot.
#'
#' @details
#' If tab is a class table object created by native table or xtabs function,
#' \code{plot_freqdist(tab)} and \code{plot(tab)} are similar. \cr
#' 
#' If weight is given, (fd, weight) or(fd[,1], weight) will be considered as
#' the frequency distribution table. \cr
#' Native barplot is used with  space=0 and las=2 and ... options as \cr
#' \code{barplot( height=fd[,2], names.arg=as.character(fd[,1])}
#' \code{, main=main, space=space, las=las, ... )}
#' \cr
#' When numeric=1 is given (default),  \code{ min(fd[,1]):max(fd[,1]) }
#' will be used as the horizontal names and 0 will be substituted for
#' the missing frequencis. \cr
#'
#' @return The object from native barplot.
#'
#' @examples
#'
#' set.seed(1701)
#'
#' score <- 0:10
#' freq <- c(0,5,10,20,30,40,30,20,10,5,0)
#' fd <- cbind(score,freq)
#' plot_freqdist( fd, main="no missing value" )
#'
#' fd1 <- fd[-c(3,7),]
#' plot_freqdist( fd1, main="score=2, 6 are missing." )
#' plot_freqdist( fd1, numeric=0
#' , main="score=2, 6 are missing and numeric=0." )
#'
#' tab=table(score)
#' tab=tab[-c(3,7)]
#' tab[]=freq[-c(3,7)]
#' plot( tab, main="using native plot function" )
#' plot_freqdist( tab, main="from class table object" )
#'
#'
#' @export
#'

plot_freqdist <- function( fd, weight=NULL, main="Frequency Distribution"
                         , numeric=1, space=0, las=2, title=NULL, ... ){
 # plot univariate frequency distributions
 # Shin-ichi Mayekawa
 # 20160808cot
 # weight: 20161202
 # numeric: 20180814dnc,17
 # bugfix for the condition has length > 1: 20220612
 #

 if( !is.null(title) ) main=title

 if( class(fd)[1] %in% c("table","xtabs") ){
  fd=table2freqdist( fd, omitmiss=0, index=1 )
 }
 else if( is.vector(fd) ) fd=matrix(fd,,1)

 nf=ncol(fd)-1
 if( nf > 1 ){
  cat("\nerror1(plot_freqdist): Input must be univariate.\n")
  stop()
 }

 if( !is.null(weight) ){
  fd=cbind(fd[,1],weight)
 }

 # horizontal value/name and hight
 x=fd[,1]
 h=fd[,2]

 # numeric
 if( numeric == 1  && is.numeric(x) ){
  locobs=which( !is.na(x) )
  x=x[locobs]; h=h[locobs]
  xx=min(x):max(x)
  hh=numeric(length(xx))
  hh[xx %in% x]=h
  x=xx; h=hh
 }

 # main body
 bp=barplot(height=h, names.arg=as.character(x)
         , main=main, space=space, las=las, ...)


 return( invisible(bp) )

} # end of plot_freqdist




#' Compress Frequency Distribution by Aggregating Duplicate Entries
#'
#' @param x Vector of values (domain of a scalar variable, numeric or string)
#' @param freq Vector of frecuencies:
#'   \code{(x, freq)} is the frequency distribution.
#' @param fill = 1 to fill the domain
#' @param domain Domain of \code{x} to be filled. (coalescing)  
#'
#' @details
#' The purpose of this function is to remove the duplicate values of \code{x}
#' and adjusting the associated frequency count in \code{freq}.
#'
#' The core part of this function is:
#' \preformatted{
#'  fnew <- xtabs( freq ~ x )
#'  xnew <- names(fnew)
#'  res <- data.frame(x=xnew, freq=fnew)
#' }
#' and if \code{domain} and \code{fill} are given, the result will be
#' coalesced. (coalescing)  
#' Using the frequency table below
#' \preformatted{
#'  x  freq
#'  1  1
#'  2  2
#'  2  1
#'  3  1
#' }
#' \preformatted{
#'   compress_freqdist( x, freq, fill=1, domain=0:4)
#' }
#' returns
#' \preformatted{
#'  x  freq
#'  0  0
#'  1  1
#'  2  3
#'  3  1
#'  4  0
#' }
#'
#' @return
#' A data frame consisting of \cr
#' \code{x} Vector of unique values \cr
#' \code{freq} Vector of frequencies
#'
#'
#' @examples
#' x <- c(1,2,4,5,6, 2,4,6, 9 )
#' f <- c(1,2,2,1,2, 1,2,1, 1 )
#'
#' ( res <- compress_freqdist( x, f ) )
#' ( res <- compress_freqdist( x, f, fill=1, domain=0:10 ) )
#'
#'
#' xc <- letters[c(1,2,4,5,6, 2,4,6, 9 )]
#' f <- c(1,2,2,1,2, 1,2,1, 1 )
#' ( res <- compress_freqdist( xc, f ) )
#' ( res <- compress_freqdist( xc, f, fill=1, domain=letters[0:10] ) )
#'
#' @export
#'

compress_freqdist <- function( x, freq, fill=0, domain=NULL ){
 # compress freqdist of the form (x, freq)
 # Shin-ichi Mayekawa
 # 20230812
 # bugfix: 20230815dnc
 # within: 20230822
 #

 fnew=xtabs( freq~x )
 if( is.numeric(x) ) xnew=as.numeric( names(fnew) )
 else xnew=names(fnew)
 fnew=unclass(fnew)
 # printm( "*", xnew, fnew )
 res=data.frame(x=xnew, freq=fnew)
 if( fill  &&  !is.null(domain) ){

  #  res=merge2( res, data.frame(x=domain, freq=0), by="x", all=TRUE )
  #  freq=ifelse( res$in.x == 1, res$freq.x, 0 )
  #  res=data.frame( x=res$x, freq=freq)
  #
  res=within( merge2( res, data.frame(x=domain, freq=0), by="x", all=TRUE )
              , freq <- ifelse( in.x == 1, freq.x, 0 ) )[,c("x","freq")]
  # Print(res)
 }

 rownames(res)=res$x
 # if( all( apply(res, 2, is.numeric)) ) res=as.matrix(res)
 # Print( res )

 return( res )

} # compress_freqdist








