feR: Basic functions that I use all the time

#......................................................................
# tengo que hacer una funcion fable PUBLICA
# que llamará cualquiera que quiera una tabla
# y otra PRIVADA que llamo YO cuando quiero generar resultados mios
#
# la privada debería tener un attributo especial
#......................................................................


.fable <- function(x,
                   # type = c("auto","pipe","html"),
                   type = "auto",
                   align = "right",
                   row.span = 1,
                   lines = matrix(c("lrb","lr","lr","rb","r","r","rb","r","r"), ncol = 3),
                   digits = 3,
                   padding = 1,
                   padding.char = " ",
                   row.divisor.char = "-",
                   col.divisor.char = "|",

                   colnames = TRUE,
                   rownames = TRUE,

                   titles.row = c(1),
                   titles.row.separa = c(1),
                   titles.row.align = "center",

                   titles.col = c(1),
                   titles.col.separa = c(1),
                   titles.col.align = "center",

                   titles.row.divisor.char = "=",
                   titles.col.divisor.char = "||",
                   stop.on.error = TRUE,
                   DEBUG = FALSE,
                   END.RECURSION = FALSE
){

  #--------------------------------- GET FULL ARGUMENTS LIST--------------------
  passed.args <- as.list(match.call(expand.dots = TRUE)[-1])
  if (!missing(x)) passed.args$x <- x
  #-----------------------------------------------------------------------------
  final.args <- get.fun.args(passed.args, "feR::fable")
  #-----------------------------------------------------------------------------

  #....... SOLO los argumentos que admite fable
  # args <- formals(fable)
  # passed.args.list <-  as.list(match.call(expand.dots = TRUE)[-1])
  # passed.args <- list()
  # for (p in names(passed.args.list)) {
  #   passed.args[[p]] <- eval(get(p))
  # }
  # final.args <- as.list(modifyList(args, passed.args))
  # # final.args$END.RECURSION <- NULL
  #
  result <-  do.call(feR::fable, final.args)
  attr(result, "END.RECURSION") <- END.RECURSION
  #..... ya es una fable normal pero con un atributo EXTRA

  return(result)

}

#' @export
fable <- function(x, ...,
                  # type = c("auto","pipe","html"),
                  type = "auto",
                  align = "right",
                  row.span = 1,
                  lines = matrix(c("lrb","lr","lr","rb","r","r","rb","r","r"), ncol = 3),
                  digits = 3,
                  padding = 1,
                  padding.char = " ",
                  row.divisor.char = "-",
                  col.divisor.char = "|",

                  colnames = TRUE,
                  rownames = FALSE,

                  titles.row = c(1),
                  titles.row.separa = c(1),
                  titles.row.align = "center",

                  titles.col = c(1),
                  titles.col.separa = c(1),
                  titles.col.align = "center",

                  titles.row.divisor.char = "=",
                  titles.col.divisor.char = "||",
                  stop.on.error = TRUE,
                  DEBUG = FALSE
                  ) {

  #--------------------------------- GET FULL ARGUMENTS LIST--------------------
  passed.args <- as.list(match.call(expand.dots = TRUE)[-1])
  if (!missing(x)) passed.args$x <- x
  #-----------------------------------------------------------------------------
  final.args <- get.fun.args(passed.args, "fable")
  #-----------------------------------------------------------------------------

  result <-  do.call(feR:::.fable.constructor, final.args)

  # if (type == "auto") {
  #   salida <- knitr::pandoc_to()
  #   consola <- is.null(salida)
  # } else {
  #   consola <- (type == "pipe")
  # }
  #
  # attr(result,"CONSOLA") <- consola

  attr(result,"type") <- type

  return(result)
}


.fable.constructor <- function(x, ...,
                               align = "right",
                               row.span = 1,
                               lines = "lr", #.... para luego
                               digits = 2,
                               padding = 2,
                               padding.char = " ",
                               row.divisor.char = "-",
                               col.divisor.char = "|",

                               colnames = TRUE,
                               rownames = TRUE,

                               titles.row = c(1),
                               titles.row.separa = NULL,
                               titles.row.align = "center",

                               titles.col = c(1),
                               titles.col.separa = NULL,
                               titles.col.align = "center",

                               titles.row.divisor.char = "-",
                               titles.col.divisor.char = "||",
                               stop.on.error = TRUE,
                               DEBUG = FALSE,
                               END.RECURSION = FALSE
            ){


  .fable.check.align(align, stop.on.error = TRUE)
  .fable.check.row_span(row.span, stop.on.error = TRUE)
  .fable.check.lines(lines, stop.on.error = TRUE)


  x.final = x


  if (colnames) {
    # x <- x %>%
    #   mutate(across(everything(), as.character))
    x <- rbind(names(x),x)
    if (is.null(titles.col.separa)) titles.col.separa = 1
    dimnames(x)[[1]][1] <- ""
  } else titles.col <- NULL

  if (rownames) {
    x <- cbind(dimnames(x)[[1]],x)
    if (is.null(titles.row.separa)) titles.row.separa = 1
  } else {
    titles.row <- NULL
  }


  x.format <- .format_matrix(as.matrix(x), digits = digits)

  attr(x.final,"FINAL") <- x.format

  x.align <- fill.matrix(x,align)
  x.rowspan <- fill.matrix(x, row.span)


  class(x.final) <- c("feR.fable",class(x.final))
  x.lines <- .fable.create.lines(x.final,lines = lines)



  attr(x.final, "ALIGN") <- x.align
  attr(x.final, "ROW.SPAN") <- x.rowspan
  attr(x.final, "PADDING") <- padding
  attr(x.final, "PADDING.CHAR") <- padding.char
  attr(x.final, "LINES") <- x.lines #.................... para luego
  attr(x.final, "ROW.DIVISOR") <- row.divisor.char
  attr(x.final, "COL.DIVISOR") <- col.divisor.char


  attr(x.final, "TITLES.ROW.SEPARA") <- titles.row.separa
  attr(x.final, "TITLES.COL.SEPARA") <- titles.col.separa
  attr(x.final, "TITLES.ROW.DIVISOR.CHAR") <- titles.row.divisor.char
  attr(x.final, "TITLES.COL.DIVISOR.CHAR") <- titles.col.divisor.char
  attr(x.final, "DEBUG") <- DEBUG
  attr(x.final, "DIGITS") <- digits

  if (!is.null(titles.col)) {
    attr(x.final, "TITLES.COL") <- titles.col
    x.final <- fable.set.align.col(x.final, pos = titles.col, align = titles.col.align)
  }
  if (!is.null(titles.row)) {
    attr(x.final, "TITLES.ROW") <- titles.row

    x.final <- fable.set.align.row(x.final, pos = titles.row, align = titles.col.align)
  }

  x.final <- .fable.lines.set.max.per.col(x.final)



  x.final
}





#' @export
fable.merge.cells <- function(x, rowIni = 1, rowEnd = 1, colIni = 1, colEnd = 1, align = "center", lines="rl") {
  .fable.check(x)

  if (colIni != colEnd) {
    row <- attr(x,"ROW.SPAN")[rowIni,]
    diff.col <- colEnd - colIni
    row[colIni:colEnd] = rep(0,times = (diff.col + 1)) #starting point is included, so if colIni = 2 and colEnd = 4, those are 3 cells
    row[colIni] <- diff.col

    x <- fable.set.row_span.row(x, pos = rowIni, row_span = row)

    row <- attr(x,"ALIGN")[rowIni,]
    row[colIni:colEnd] = rep(align,times = (diff.col + 1)) #starting point is included, so if colIni = 2 and colEnd = 4, those are 3 cells
    x <- fable.set.align.row(x, pos = rowIni, align = row)


    x <- .fable.lines.update(x)
    x <- fable.set.lines.cell(x, row = rowIni, col = colEnd, lines = lines)
  }
  return(x)
}



#...............................................................................
#...............................................................................
# ADD  ROW  ---  ALIGN, ROW.SPAN and FABLE
#...............................................................................
#...............................................................................

#' @export
fable.add.row <- function(x,row = "-", pos = 0, align = "center", lines = "copy", row.to.copy.lines = 2, row_span = 1, DEBUG = FALSE) {

  .fable.check(x)
  digits <- attr(x,"DIGITS")
  x.format <- add.row(attr(x,"FINAL"), row = row, pos = pos, DEBUG = DEBUG)
  x.format <- .format_matrix(x.format, digits = digits, DEBUG = DEBUG)

  attr(x,"FINAL") <- x.format

  x <- fable.add.align.row(x, pos = pos, align = align, DEBUG = DEBUG)
  x <- fable.add.row_span.row(x, pos = pos, row_span = row_span, DEBUG = DEBUG)
  x <- fable.add.lines.row(x, pos = pos, lines = lines, row.to.copy.lines = row.to.copy.lines, DEBUG = DEBUG)
  x
}



#...............................................................................
#...............................................................................
# ADD  COLUMN  ---  ALIGN, ROW.SPAN and FABLE
#...............................................................................
#...............................................................................


#' @export
fable.add.column <- function(x,col = "-", pos = 0, align = "center", lines = "copy", col.to.copy.lines = 2, row_span = 1, DEBUG = DEBUG) {

  .fable.check(x)
  digits <- attr(x,"DIGITS")
  x.format <- add.col(attr(x,"FINAL"), col = col, pos = pos, DEBUG = DEBUG)
  x.format <- .format_matrix(x.format, digits = digits, DEBUG = DEBUG)

  attr(x,"FINAL") <- x.format

  x <- fable.add.align.col(x, pos = pos, align = align, DEBUG = DEBUG)
  x <- fable.add.row_span.col(x, pos = pos, row_span = row_span, DEBUG = DEBUG)
  x <- fable.add.lines.col(x, pos = pos, lines = lines, col.to.copy.lines = col.to.copy.lines, DEBUG = DEBUG)
  x
}

#' @rdname fable.add.column
#'
#' @export
fable.add.col <- fable.add.column


#' @export
fable.set.cell <- function(x,row,col,item, DEBUG = F) {
  .fable.check(x)
  if (row > nrow(x)) stop("row out of bounds")
  if (col > ncol(x)) stop("row out of bounds")

  digits <- attr(x,"DIGITS")
  x.format <- attr(x,"FINAL")
  x.format[row,col] = item
  x.format <- .format_matrix(x.format, digits = digits, DEBUG = DEBUG)

  attr(x,"FINAL") <- x.format
  x
}




#'@export
as.matrix.feR.fable <- function(x){
  class(x) <- "matrix"
  attributes(x) <- NULL
  x
}


#'@export
as.data.frame.feR.fable <- function(x){
  class(x) <- "data.frame"
  n <- names(x)
  r <- rownames(x)
  attributes(x) <- NULL
  names(x) <- n
  rownames(x) <- r
  x
}





.pad_array <- function(x, max_char = NULL, align = NULL,
                       padding = 2, padding.char = " ", row_sep.char ="=",
                       DEBUG = FALSE) {


  x <- .format_matrix(x, digits = ifelse(is.feR.fable(x), attr(x,"DIGITS"),NULL), DEBUG = DEBUG)


  max_char <- max_nchar(x)
  max_char = max_char + (padding*2) #..... padding is on both sides


  if (DEBUG) cat("\nMAX_CHAR:", max_char,"\n")

  result <- matrix(ncol = ncol(x),nrow = nrow(x))
  for (r in seq_len(nrow(x))) {
    for (c in seq_len(ncol(x))) {
      # print(align[r,c])
      result[r,c] <- .pad_cell(x[r,c],max_char = max_char[c],
                                 align = align[r,c], padding = padding,
                                   padding.char = padding.char, DEBUG = DEBUG)
    }
  }

  result <- matrix(result,nrow = nrow(x))
   # result <- t(apply(x,1,.pad_row, DEBUG=DEBUG, max_char = max_char,
   #                    align = align, padding = padding, padding.char = padding.char,
   #                    row_sep.char = row_sep.char))
  rownames(result) <- rownames(x)
  dimnames(result) <- dimnames(x)

  attr(result, "MAX_CHAR_PER_COL") <- max_char

  result

}

.pad_cell <- function(v,max_char=NULL, align="right", padding = 2, padding.char = " ", trimws = FALSE, DEBUG=F){
  if (is.null(max_char)) max_char <- max_nchar(v)

  if (trimws) v <- trimws(v)
  v_nchar <- .max_nchar.character(v)
  # v_nchar <- nchar(sprintf("%s",v), type="width")
  # nchar.v <- nchar(v, type = "width")
  resto <- max_char - (v_nchar) + (padding*2)

  if (align == "right") {
    l.p <- resto
    r.p <- 0
  } else if (align == "left") {
    r.p <- resto
    l.p <- 0
  } else if (align == "center") {
    l.p <- (resto)/2
    r.p <- trunc(l.p)
    l.p <- r.p
    if (resto %% 2 > 0) l.p <- l.p + 1
  }

  total_char <- l.p + r.p + v_nchar
  if (DEBUG) cat("\n -total: ",total_char,"max: ",max_char," -- V_NCHAR:",v_nchar,"l.P:",l.p," --  r.P:",r.p," -- ",v[n],"\n")


  if (total_char < max_char) {
    if (DEBUG) cat("\n Total < que max, nuevl l.p: ",l.p,"\n")
    l.p <- l.p + (max_char - total_char)
  }
  v <- paste0(paste0(rep(padding.char,times = l.p),collapse = ""),v,paste0(rep(padding.char,times = r.p),collapse = ""))

  v
}




#...............................................................................
#...............................................................................
# SEPARATION LINES
#...............................................................................
#...............................................................................

.fable.line.set <- function(x, lines = "lr") {
  if (is.matrix(lines)) {
    if ( (nrow(lines) != nrow(x)) | (ncol(lines) != ncol(x)) ) stop("lines matrix size is wrong")
    else {
      return(lines)
    }
  }

  if (length(lines) == 1) {
    final.lines <- matrix(rep(lines, times = length(as.matrix(x))), ncol = ncol(x))
    return(final.lines)
  }

  if (length(lines) == ncol(x)) {
    final.lines <- matrix(rep(lines, times = nrow(x)), ncol = ncol(x), byrow = TRUE)
    return(final.lines)
  }
}



.fable.check <- function(x) {
  if (!is.feR.fable(x)) stop("'x' debe ser un objeto feR.fable")
}



#' @export
is.feR.fable <- function(x) {
  if ("feR.fable" %in% class(x)) TRUE
  else FALSE
}



.format_matrix <- function(x,digits=2, row_sep.char = "-", DEBUG = F){
  # print(x)
  if(!is.data.frame(x) & !is.matrix(x)) stop("[.format_matrix] x must be a matrix")
  total_columns <- ncol(x)

  x.full <- c()
  for (c in 1:total_columns) {
    valores <- x[,c]

    if (is.numeric(valores)) {
      format.num = paste0("%.",max_num_decimals(valores,digits = digits),"f")
      temp <- sprintf(format.num, valores)
    }
    else temp <- sprintf("%s", trimws(valores, which = "both"))

    x.full <- c(x.full,temp)
  }

  result <- matrix(x.full, ncol = total_columns, nrow = nrow(x))
  rownames(result) <- rownames(x)
  dimnames(result) <- dimnames(x)
  result
}