#' Comment out multiple lines
#'
#' @param ... lines to be commented out in matched quotes
#' @return None
#' @examples comments(' whatever you want except for single quotes ')
#' @export
#'

comments <- function(...){
 # block comments
 # Shin-ichi Mayekawa
 # 111126,30,1203
 #
 # use this as
 #   comments('
 #             whatever, as many lines as, ...
 #            ')
 #
 return(invisible())
} # end of comments



#' Retruns the Last Value
#'
#' @param ... Not Used
#'
#' @examples
#' \dontrun{
#' set.seed(1701)
#' rnorm(10)
#' lv()
#' }
#' 
#' @export
#'

lv <- function( ... ){
 # functoin to return the last value: (Value of Last Evaluated Expression)
 # Shin-ichi Mayekawa
 # 120125
 # renamed as lv: 20150620
 # ... added as argument: 20230808dnc
 #
 
 return(.Last.value)
} # end of lv









#' Find the mode/typeof of the columns of data
#'
#' @param data a data frame to be checked.
#' @param typeof = 1 to return typeof(var) instead of mode(var)
#'
#' @details
#'    mode   -> "numeric", "character", etc \cr
#'    typeof -> "integer", "double", "character", etc \cr\cr
#' When data contains factors, "factor" will be returned for those varaibles.
#'
#' @return a vector consisting of typeof or mode.
#'
#' @examples
#'  df=data.frame(a=1,b="a",c=as.factor(1), stringsAsFactors=0)
#'  vartype(df)
#'  vartype(df, typeof=1)
#'  ls=list(a=1:2,b=2:4,c=c("a","b"),A=diag(2))
#'  vartype(ls)
#'  vartype(ls, typeof=1)
#'
#' @export
#'
vartype <- function( data, typeof=0 ){
 # find the mode/typeof of the columns of data
 # Shin-ichi Mayekawa
 # 20140226
 # treatment of factor: 20140604,10
 # list is a vector: 20140610,20160731
 #
 #
 # Args:
 #
 #  data    data frame, matrix or vector
 #
 #  typeof  = 1 to return typeof(data) instead of mode(data)
 #
 #
 # Values
 #  returns the value of mode or typeof functon:
 #    mode   -> "numeric", "character", etc
 #    typeof -> "integer", "double", "character", etc
 #
 #  When data contains factors, "factor" will be returned for those varaibles.
 #
 #  sapply( data.frame, class ) will give you the same result.
 #  sapply( list,       class ) will be different.
 #
 #

 # location of factors
 if( is.factor(data) ) locf=TRUE
 else if( is.matrix(data) | is.vector(data) )
  locf=FALSE
 else if( is.list(data) )
  locf=sapply(data,is.factor)
 locf=which(locf)

 type=NULL
 if( typeof != 1 ){
  if( is.array(data) | (is.vector(data) & !is.list(data)) )
   type=mode(data)
  else if( is.list(data) )
   type=sapply(data,mode)
 }
 else{
  if( is.list(data) )
   type=sapply(data,typeof)
  else if( is.array(data) | is.vector(data) )
   type=typeof(data)
 }

 if( is.null(type) ) type=rep("factor",length(locf))
 else type[locf]="factor"

 return( type )

} # end of vartype




#' Displays the attribuets and the structure of the input.
#'
#' @param X an object whose info we would like to have.
#' @param opt = 1 to print structure only.\cr
#' =2 to print attributes only.
#'
#' @return A list
#'
#' @examples
#'   bool <- TRUE
#'   num <- 1
#'   cpl <- 1+1i
#'   strng <- "Hello."
#'   vec <- 1:10
#'   mat <- matrix(c(1, 2, 3), 3, 2)
#'   array <- array(1,c(2,2,2))
#'   df <- data.frame(a=1,b=letters[1:2])
#'   lis <- list(a=1:3, b="abc",NA)
#'
#'   was(bool)
#'   was(num)
#'   was(cpl)
#'   was(strng)
#'   was(vec)
#'   was(mat)
#'   was(array)
#'   was(df)
#'   was(c)
#'
#' @export
#'

was <- function( X, opt=0 ){
 # Returns info on X
 # Shin-ichi Mayekawa
 # 111031,1101
 # avoid str and opt option: 20150528
 # size -> was: 20150605
 # output format, size of df: 20181101dnc,06
 #
 # type of basic R object
 #  logical, integer, real, complex, string (or character) and raw
 #
 # mode of R object
 #
 # typeof    mode      storage.mode
 # ---------------------------------
 # logical   logical   logical
 # integer   numeric   integer
 # double    numeric   double
 # complex   complex   complex
 # character character character
 # raw       raw       raw
 # ---------------------------------
 #
 #
 # Homogeneous Data Structures: vector, factor, matrix and array.
 # Only one mode in the structure.


 # Object	Max dimension	One mode of
 # --------------------------------------------------------------------
 # vector 	1            	numeric, character, complex or logical
 # factor 	1            	numeric or character
 # matrix 	2            	numeric, character, complex or logical
 # array  	n            	numeric, character, complex or logical
 # --------------------------------------------------------------------


 # Heterogeneous Data Structures:
 #
 # list	        n             	can be of mixed mode
 # data frame	  n             	can be of mixed mode
 #


 name2=c("vector","matrix","array","list","data.frame","factor","ordered")
 res1=attributes(X)
 res1=append( res1, list(
  length=length(X),
  mode=mode(X),
  storage.mode=storage.mode(X),
  typeof=typeof(X)
 ))

 res2=c(
  is.vector(X),
  is.matrix(X),
  is.array(X),
  is.list(X),
  is.data.frame(X),
  is.factor(X),
  is.ordered(X)
 )

 if( is.data.frame(X) ){
  dim=dim(X)
  res1=append( list(dim=unlist(dim)), res1 )
 }

 # Print(res1)
 # Print(name2[res2])

 if( opt == 1 ) return(name2[res2])
 else if( opt == 2 ) return(res1)
 else  return (list(Shape=name2[res2], Size=res1))

} # end of was






#' Column standardization of a data frame, matrix, or vector
#'
#' @param X data frame, matrix, or vector \cr
#' If X contains non-mumeric variable, they will be left as they are.
#' @param center = 1 to perform column centering only.
#' @param vardef = "n-1" to use unbiased variance
#' @return The standardized input.
#' @details When X is a data frame or matrix, the colums of which
#'  will be standardized. \cr
#'  NaN will be returned for those variables with 0 variance.
#' @examples
#' standard( data.frame(id=paste("id",1:5,sep=""), diag(5), a="a") )
#'
#' @export
#'

standard <- function( X, center=0, vardef="n" ){
 # column standardization of X
 # Shin-ichi Mayekwa
 # 130110,11,12
 # proper way to remove attributes: 20140601 cot, 0604
 # vartype: 20140604,05
 # return a vector when X is a vector: 20140604
 #
 # Args:
 #
 #   X        a matrix to be centered/standardized
 #   center   = 1 to perform centering only
 #   vardef   = "n-1" to use 'R default'unbiassed' formula
 #
 # Value:
 #
 #   Z        column centered/standardized matrix
 #            non-numeric variables, including factors, are left as they are.
 #
 #
 # Needs:
 #
 #   vartype
 #


 # location of numeric varaibles excluding factors
 locn=which(vartype(X) == "numeric" )
 if( length(locn) == 0 ) return(X)

 # is X a vector?
 isvec=0
 if( is.vector(X) ) isvec=1

 # make copy of X if there are non numeric variables in X
 subset=0
 if( is.data.frame(X) )
  if( ncol(X) > length(locn) ){
   XX=X
   X=X[,locn]
   subset=1
  }

 # standardize to 0-1
 if( center != 0 )
  X=scale(X,center=TRUE,scale=FALSE)
 else{
  X=scale(X,center=TRUE,scale=TRUE)
  # vardef
  if( vardef == "n" ){
   if( is.matrix(X) )  n=nrow(X)
   else n=length(X)
   X=X/sqrt((n-1)/n)
  }
 }

 # remove attributes
 attributes(X)$`scaled:center`=NULL
 if( !is.null( attributes(X)$`scaled:scale`) )
  attributes(X)$`scaled:scale`=NULL

 # post processing
 if( subset == 1 ){
  # recover nun numeric variables
  XX[,locn]=X
  return( XX )
 }
 else{
  # vectorize
  if( isvec ) X=c(X)
  return( X )
 }

} # end of standard





#' Inverse of Cummurative Sum
#'
#' @param x A numeric vector
#'
#' @details
#' This function returns lagged difference of lagg=1 and x[1] as: \cr
#'  c( x[1], diff(x,1) )
#'
#' @return
#' A vector of the inverse of cumsum.
#'
#' @examples
#' set.seed(1701)
#' x=sample(1:9,9,replace=1)
#' y=cumsum(x)
#' Print(x,y,cumsuminv(y))
#'
#' @export
#'

cumsuminv <- function( x ){
 # inverse of cummulative sum
 # Shin-ichi Mayekawa
 # 20150620
 #
 x=c(x)
 return( c(x[1],diff(x,1)) )
} # end of cumsuminv



#' Return the Ceiling and Power of the Input using Radix (Base) of n
#'
#' @param x input vector, x > 0
#' @param n Radix or Base
#'
#' @details
#'  When n=10 \cr
#'     0   <= x <    10,    ceiling_n(x)$val=10,  ceiling_n(x)$power=1 \cr
#'    10   <= x <   100,    ceiling_n(x)$val=100,  ceiling_n(x)$power=2 \cr
#'   100   <= x <  1000,    ceiling_n(x)$val=1000,  ceiling_n(x)$power=3 \cr
#'  When n=2 \cr
#'     0   <= x <     2,  ceiling_n(x,2)$val=2,  ceiling_n(x,2)$power=1 \cr
#'     2   <= x <     4,  ceiling_n(x,2)$val=4,  ceiling_n(x,2)$power=2 \cr
#'     4   <= x <     8,  ceiling_n(x,2)$val=8,  ceiling_n(x,2)$power=3 \cr
#'
#' @return
#' A list of: \cr
#' power The power \cr
#' val   The value of ceiling = n^power
#'
#' @examples
#' ceiling_n( c(1,9,10,99,100) )
#' ceiling_n( c(1,2,3,4,7,8,15,16), n=2 )
#'
#' @export
#'

ceiling_n <- function( x, n=10 ){
 # returns the ceiling of decimal x using radix (base) of n
 # Shin-ichi Mayekawa
 # 20150601
 # error check: 20150620
 #
 # When n=10
 #    0   <= x <    10     10
 #   10   <= x <   100    100
 #  100   <= x <  1000   1000
 # When n=2
 #    0   <= x <     2     2
 #    2   <= x <     4     4
 #    4   <= x <     8     8
 #

 x=c(x)
 if( any(x <= 0) ){
  cat("\n\nerror1:(ceiling_n) Input must be positive,\n")
  return( NULL )
 }

 power=( floor( log(x)/log(n) + 1e-99998 )+1 )
 val=n^power
 return( list(power=power, val=val) )

} # end of ceiling_n



#' Returns the (approximate) # of Digits on the Both Sides of the Decimal Point
#'
#'
#' @param num A numeric vector
#' @param maxpower 10 or higher
#'
#' @return A vector or matrix containing the # of digits
#'
#' @examples
#' decp(c(-5.2,-3.99, 0, 1, 1.2, 5.23, 9999.8888, 99999999.8888888888))
#'
#' @export
#'

decp <- function( num, maxpower=10 ){
 # returns the # of digits at the both sides of the decimal point
 # Shin-ichi Mayekawa
 # IML version: 031116(AIEJ)
 # 20111122
 # vector input: 20120204
 # bugfix: 120204
 #
 # Value: a matrix of
 #   num  left  right
 #
 # Note:
 #  If you see the following warning message:
 #     probable complete loss of accuracy in modulus
 #   try to increase/decrease maxpower constant. It might help.
 #
 # This program needs to be improved.
 #

 if( is.matrix(num) ) num=as.vector(num)
 n=length(num)
 res=matrix(0,n,3); res[,1]=num
 colnames(res)=c("num","left","right")
 num=abs(num)

 for( i in 1:n ){
  numi=num[i]

  # left
  w1=floor(log(abs(numi))/log(10))+1
  if( w1 < 0 ) w1=0

  # right
  for ( w2 in 0:maxpower ){
   mod1=( (10^w2)*numi ) %% 1
   if ( abs(mod1) <= 1e-8 ){
    break
   }
   # Print(numi,w2, (10^w2)*numi,mod1,w2)
  }

  # adjust for integers
  if( numi == floor(numi) ) w2=0
  res[i,2:3]=c(w1,w2)

 } # end of i loop

 res[which(res[,1] == 0),]=0
 if( n == 1 ) res=as.vector(res)
 return( res )

} # end of decp






#' Generate all combinations of n elements taken m at a time.
#'
#'   This is very slow when n is large.
#'
#' @param n total # of elements
#' @param m # of elements to choose
#'
#' @details
#' This function uses cprod function to calculate combinations. \cr
#' For example,
#'  n choose 3 will be calculated as: \cr
#'  x <- 1:n \cr
#'  y <- cprod(x,x[-1]) \cr
#'  y <- y[y[,1]<y[,2],] \cr
#'  y <- cprod(y,x[-(1:2)]) \cr
#'  y <- y[y[,2]<y[,3],] \cr
#'
#' @return
#' A matrix of the size choose(n,m) x m.
#'
#' @examples
#' n <- 5
#' for( m in 1:n )
#'  Print( m,choose(n,m), comb(n,m) )
#'
#' @export
#'

comb <- function( n, m ){
 # Generate all combinations of the elements of x taken m at a time
 # Shin-ichi Mayekawa
 # 20150627
 #
 x=matrix(1:n,n,1)
 dimnames(x)=NULL

 if( m == 1 ) return( x )
 if( m == n ) return( t(x) )

 y=cprod(x,x[-1])
 y=y[y[,1]<y[,2],]
 dimnames(y)=NULL
 if( m == 2 ) return( y )

 for( i in 3:m ){
  y=cprod(y,x[-(1:(i-1))])
  y=y[y[,i-1]<y[,i],]
 }
 dimnames(y)=NULL
 return(y)

} # end of comb






#' Print an Object with Print function with fuzz= option
#'
#' @param obj An object to be printed
#' @param fuzz fuzz parameter of Print
#' @param ntogoback n parameter of sys.parent function
#'
#' @details
#' When used with postfix function application operator of
#' \strong{lazy.symbolic} package as
#' \code{ lv() \%//\% fuzz }, \cr
#' .fuzz. global variable will be referenced instead of fuzz parameter.
#'
#' @examples
#' Ap <- c(1e-2,1e-5,1e-7)
#' Ap
#' fuzz(Ap)
#' # Above is equivalent to: Ap %//% fuzz
#' .fuzz. <- 1e-6
#' fuzz(Ap)
#' #Ap %//% fuzz
#'
#' @export
#'
fuzz <- function( obj, fuzz=1e-4, ntogoback=1 ){
 # print an object by Print with the fuzzy option
 # Shin-ichi Mayekawa
 # 20150928DNC
 #

 if( exists( ".fuzz.", where=sys.frame(sys.parent(n=ntogoback)) ) ){
  .fuzz=.fuzz.
  if( !is.null(.fuzz)  &  is.numeric(.fuzz) ) fuzz=.fuzz
 }

 Print(obj, fuzz=fuzz)
 return( invisible() )

} # end of fuzz




#' Overlay strings
#'
#' @param ... Strings to be overlayed. Eeach string must be a scalar.
#' @param bottom = 0 to overlay on top of the last string
#' @param blanks Characters which will be treated as blank.
#' @param BLANK Blank character to be used in the final result.
#'
#' @details
#' When bottom=1, the i th string will be overlayed on top of i-1 th. \cr
#'
#' @examples
#' c1="12345 78 01"
#' c2="a c:efg x"
#' str_olay( c1,c2 )
#' str_olay( c1,c2, bottom=0 )
#' str_olay( c1,c2, blanks=": " )
#'
#' @export
#'

str_olay <- function( ..., bottom=1, blanks=" ", BLANK=" " ){
 # overlay string
 # Shin-ichi Mayekawa
 # 20151008
 #

 # blanks
 blanks=strsplit(blanks,"")[[1]]

 # 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]
 }
 val=unlist(val)
 narg=length(val)

 # Print(name,val)

 if( narg == 0 ) return( NULL )
 else if( narg == 1 ) return( val[1] )

 if( bottom != 1 ){
  val=val[narg:1]
 }

 res=strsplit(val[1],"")[[1]]
 for( i in 2:narg ){
  v=strsplit(val[i],"")[[1]]
  for( j in 1:length(v) ){
   if( !(v[j] %in% blanks) ) res[j]=v[j]
  }
 }

 # final
 res[is.na(res) | (res %in% blanks)]=BLANK

 res=paste(res,collapse="")

 # Print(res)

 return( res )

} # end of str_olay




#' Find the Complexity Index of a 0-1 String
#' Definded as the Number of Switches from "01" to "10" to Make It Simple.
#'
#' @param pat01 A matrix consisting of 0s or 1s \cr
#' or a vector whose elements are strings consisting of 0s and 1s.
#' @param rev = 1 to count the # of switches from "10" to "01".
#' @param print = 1 to print the intermediate result.
#'
#' @details
#' When rev == 0, if a string contains no 1's to the left of 0's
#' it is assumed to simple. \cr
#' This function returns the # of switches from "01" to "10"
#' in order to make the string simple. \cr
#' \cr
#' When rev == 0, the roles of 0 and 1 will be interchanged.
#' \cr\cr
#' When the input is a matrix or data frame, complexity index of each row will
#' be calculated.
#'
#' @return
#' A vector consisting of the # of switches for each string.
#'
#' @examples
#'
#' complex_index("0101", print=1 )
#' pat01=matrix(c(0,1,1,0,0,1,0,1,0,0,1,1,0,0),2)
#' res=complex_index( pat01 )
#' Print(pat01,res)
#'
#' @export
#'

complex_index <- function( pat01, rev=0, print=0 ){
 # find the # of simple switches between 01 and 10 to achieve total simplicity.
 # Shin-ichi Mayekawa
 # old iml version 19930402
 # 20161208
 #
 #

 # target
 if( rev == 0 ){
  from="01"; to="10"
 }
 else{
  from="10"; to="01"
 }
 # make the input a matrix
 if( is.data.frame(pat01) ) pat01=as.matrix(pat01)
 else if( is.vector(pat01) ){
  nc=nchar(pat01)
  if( all( nc == 1 ) ){
   # each element of the vector has 1 character
   # make it a row vector
   pat01=matrix(pat01,1)
  }
  else{
   # the # of chars in each element of the vector is different
   # make it a col vector
   pat01=matrix(pat01,,1)
  }
 }

 # concatenate if there are multiple columns
 if( ncol(pat01) > 1 ) pat01c=( apply(pat01,1,paste, collapse="") )
 else pat01c=pat01

 n=nrow(pat01)
 res=numeric(n)
 for( i in 1:n ){
  pi=pat01c[i]
  if( print ) cat(i, "   :", pi, "\n")
  c=0
  while( length(grep(from, pi)) > 0 ){
   c=c+1
   pi=sub(from, to, pi)
   if( print ) cat(c, "   :", pi, "\n")
  }
  res[i]=c
 }

 return(res)

} # end of complex_index



