R/print.fable.R

Defines functions print.feR.fable .fable.html .fable.pipes .fable.pipes.constructor

.fable.pipes.constructor <- function(x, DEBUG=F) {
  x.orig <- x
  align <- attr(x, "ALIGN")
  row_span <- attr(x, "ROW.SPAN")
  lines <- attr(x,"LINES")
  max.lines.per.col <- attr(x,"MAX_LINES_PER_COL")

  col.divisor.char <- attr(x,"COL.DIVISOR")
  row.divisor.char <- attr(x,"ROW.DIVISOR")
  titles.rows <- attr(x,"TITLES.ROW")
  titles.col <- attr(x,"TITLES.COL")
  titles.rows.separa <- attr(x,"TITLES.ROW.SEPARA")
  titles.col.separa <- attr(x,"TITLES.COL.SEPARA")
  titles.row.divisor.char = attr(x, "TITLES.ROW.DIVISOR.CHAR")
  titles.col.divisor.char = attr(x, "TITLES.COL.DIVISOR.CHAR")
  padding <- attr(x, "PADDING")
  padding.char <- attr(x, "PADDING.CHAR")
  x <- attr(x,"FINAL")


  if (DEBUG) cat("\n [.fable.pipes.constructor] ", class(x), "  \n")
  x <- .pad_array(x, align = align, padding = padding,  padding.char = padding.char,
                  DEBUG = DEBUG)

  max_char_per_col <- attr(x,"MAX_CHAR_PER_COL")


  final <- c()
  # print(row_span)
  for (r in seq_len(nrow(x))) {

    r.temp.span <- c()
    cont.span = 0
    nchar.span = c()

    t.linea <- c()
    top.linea <- c()
    bot.linea <- c()
    line.has.top = .fable.lines.has.line.in.row(x.orig,row = r, line = "t")
    line.has.bot = .fable.lines.has.line.in.row(x.orig,row = r, line = "b")

    row.title = FALSE

    # prev.linea.celda = ""
    prev.texto.celda = ""
    prev.span.celda = 1
    temp.texto.celda = ""
    span.total.char = 0

    for (c in seq_len(ncol(x))) {

      PRINT.CELDA = FALSE
      CIERRA.SPAN = FALSE
      CONTINUA.SPAN = FALSE

      linea.celda <- lines[r,c]

      texto.celda <- x[r,c]
      span.celda <- row_span[r,c]





      # print(span.celda)







      if (span.celda == 1) {
        PRINT.CELDA = TRUE
        if (prev.span.celda == 0) CIERRA.SPAN = TRUE
      } else if (span.celda > 1) {
        inicio.span.linea = linea.celda
        inicio.span.col = c
        if (prev.span.celda != 0) {
          temp.texto.celda = texto.celda
          span.total.char = max_nchar(texto.celda)
        } else {
          CIERRA.SPAN = TRUE
          CONTINUA.SPAN = TRUE
        }
      } else if (span.celda == 0) {
        temp.texto.celda = paste0(temp.texto.celda," ", texto.celda)
        span.total.char = span.total.char + max_nchar(texto.celda) + ((padding*2) - 1)
        texto.celda = ""
      }

      if ((c == ncol(x)) & (temp.texto.celda != "")) CIERRA.SPAN = TRUE

      # cat("\nR: ",r,"  C:",c,"  CIERRA.SPAN:",CIERRA.SPAN,"   SPAN:",span.celda,"  TEXTO:",texto.celda,"\n")
      if (CIERRA.SPAN) {
        PRINT.CELDA = TRUE
        print.texto = temp.texto.celda #.... el que viene acumulado
        temp.texto.celda = texto.celda
        texto.celda = print.texto


        span.col.diff <- c - inicio.span.col
        max_char_span <- sum(max_char_per_col[inicio.span.col:c]) +  #... total de LETRAS en todas las columnas
                            ((span.col.diff)*(padding*2))   +        #.... total de padding
                            (span.col.diff * nchar(col.divisor.char))#.... total de columnas (por los divisores)

        texto.celda <- .pad_cell(trimws(print.texto), max_char = max_char_span, align = align[r,c], padding = padding, padding.char = padding.char)
        linea.celda = paste0(unique_chars(paste0(inicio.span.linea,linea.celda, collapse = "")),collapse = "")
      }

      if (PRINT.CELDA) {

        col.title = ( (c %in% titles.col) & (c %in% titles.col.separa) )
        row.title = ((r %in% titles.rows) & (r %in% titles.rows.separa))

        if (col.title) temp.col.divisor = titles.col.divisor.char
        else temp.col.divisor = col.divisor.char

        if (row.title) temp.row.divisor = titles.row.divisor.char
        else temp.row.divisor = row.divisor.char

        if (grepl("t",linea.celda, fixed = TRUE)) {
          if (grepl("l",linea.celda, fixed = TRUE)) top.linea <- c(top.linea,temp.col.divisor)
          top.linea <- c(top.linea,rep(temp.row.divisor,times = max_nchar(texto.celda)))
          if (grepl("r",linea.celda, fixed = TRUE)) top.linea <- c(top.linea,temp.col.divisor)
        } else if (line.has.top) {
          if (grepl("l",linea.celda, fixed = TRUE)) top.linea <- c(top.linea,temp.col.divisor)
          top.linea <- c(top.linea,rep(" ",times = max_nchar(texto.celda)))
          if (grepl("r",linea.celda, fixed = TRUE)) top.linea <- c(top.linea,temp.col.divisor)
        }

        if (grepl("b",linea.celda, fixed = TRUE)) {
          if (grepl("l",linea.celda, fixed = TRUE)) bot.linea <- c(bot.linea,temp.col.divisor)
          bot.linea <- c(bot.linea,rep(temp.row.divisor,times = max_nchar(texto.celda)))
          if (grepl("r",linea.celda, fixed = TRUE)) bot.linea <- c(bot.linea,temp.col.divisor)
        } else if (line.has.bot) {
          if (grepl("l",linea.celda, fixed = TRUE)) bot.linea <- c(bot.linea,temp.col.divisor)
          bot.linea <- c(bot.linea,rep(" ",times = max_nchar(texto.celda)))
          if (grepl("r",linea.celda, fixed = TRUE)) bot.linea <- c(bot.linea,temp.col.divisor)
        }

        if (grepl("l",linea.celda, fixed = TRUE)) t.linea <- c(t.linea,temp.col.divisor)


        t.linea <- c(t.linea,texto.celda)

        if (grepl("r",linea.celda, fixed = TRUE)) t.linea <- c(t.linea,temp.col.divisor)



      }#........ fin PRINT.CELDA

      if (CIERRA.SPAN & !CONTINUA.SPAN) temp.texto.celda = ""
      prev.texto.celda <- texto.celda
      # prev.line.celda <- linea.celda
      prev.span.celda <- span.celda
    }
    #..... fin for column
    if (length(top.linea) > 0) final <- c(final,paste0(top.linea, collapse = ""))
    final <- c(final,paste0(t.linea, collapse = ""))
    if (length(bot.linea) > 0) final <- c(final,paste0(bot.linea, collapse = ""))

  }#.... fin for row

  final



}


.fable.pipes <- function(x, DEBUG = F) {

  x.final <- .fable.pipes.constructor(x)
  cat(x.final,sep = "\n")
}


.fable.html <- function(x,DEBUG=F) {
  align <- attr(x, "ALIGN")
  row_span <- attr(x, "ROW.SPAN")
  lines <- attr(x,"LINES") #..... para luego
  col.divisor.char <- attr(x,"COL.DIVISOR")
  titles.rows <- attr(x,"TITLES.ROW")
  titles.col <- attr(x,"TITLES.COL")
  titles.rows.separa <- attr(x,"TITLES.ROW.SEPARA")
  titles.col.separa <- attr(x,"TITLES.COL.SEPARA")
  titles.row.divisor.char = attr(x, "TITLES.ROW.DIVISOR.CHAR")
  titles.col.divisor.char = attr(x, "TITLES.COL.DIVISOR.CHAR")
  padding <- attr(x, "PADDING")
  padding.char <- attr(x, "PADDING.CHAR")
  x <- attr(x,"FINAL")


  x <- .pad_array(x, align = align, padding = padding,  padding.char = padding.char,
                  DEBUG = DEBUG)


  final <- paste0("<table style='width:100%; margin: 0px auto;'>")


  for (r in seq_len(nrow(x))) {

    row.style = ""

    if (r %in% titles.rows.separa) {
      row.style <- "border-bottom: 1px solid;"
      final <- c(final,paste0("<tr style='",row.style,"'>"))
    } else final <- c(final,paste0("<tr",row.style,">"))

    for (c in seq_len(ncol(x))) {
      style = paste0(" style='padding:",padding,"px; border-spacing: 10px;")
      # style = paste0(" style='")
      col.style = ""
      align.style = ""
      tag = ""

      align.rc = align[r,c]
      # cat("\n ALIGN" ,align.rc)

      if (c %in% titles.col.separa) col.style = " border-right:1px solid;"
      if (align.rc == "left") align.style = " text-align: left;"
      else if (align.rc == "right") align.style = " text-align: right;"
      else if (align.rc == "center") align.style = " text-align: center;"


      if ((r %in% titles.rows) || (c %in% titles.col)) {
        tag = "<th"
        end.tag = "</th>"
      }
      else {
        tag = "<td"
        end.tag = "</td>"
      }

      final <- c(final,paste0(tag,style,row.style,col.style,align.style,"'>"),x[r,c],end.tag)
    }
    final <- c(final,"</tr>")
  }

  final <- c(final,"</table>")
  final <- paste0(final,collapse = "")

  cat(final,sep = "\n")
}

#' @export
print.feR.fable <- function(x) {

  type <- attr(x,"type")

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

  # attr(result,"CONSOLA") <- consola

  # cat("\n ------ CONSOLA: ",consola,"    \n")
  if (is.null(consola)) consola <- TRUE
  DEBUG <- attr(x, "DEBUG")

  end.recursion = FALSE
  if ("END.RECURSION" %in% names(attributes(x))) end.recursion = attr(x,"END.RECURSION")
  if (is.feR.object(x) & !is.feR.fable(x)) {
    if (end.recursion) {

      if (consola) .fable.pipes(fable(x), DEBUG = DEBUG)
      else .fable.html(x, DEBUG = DEBUG)
    }
    else {

      x.p <- x
      class(x.p) <- class(x.p)[-1]
      print(x.p)
    }
  } else {
    if (consola) .fable.pipes(x, DEBUG = DEBUG)
    else .fable.html(x, DEBUG = DEBUG)
  }
}
feranpre/feR documentation built on Nov. 22, 2022, 2:29 a.m.