R/blockMessage.R

In BlockMessage: Creates strings that show a text message in 8 by 8 block letters

blockMessage <-
function(message, symbols = c("X"," "), font = NULL, font_names = NULL, width = 7, asData = 0, portrait=TRUE, rotate=0, repeats=1)
{
 # convert a string of characters into block letters each letter made up by symbols in an 8 by 8 grid

  if (is.null(font))
    font <- matrix(c('7F','88','88','88','7F','00','00','00','FF','91','91','91','6E','00','00','00','7E',
      '81','81','81','42','00','00','00','FF','81','81','42','3C','00','00','00','FF','91','91','91','81',
      '00','00','00','FF','90','90','90','80','00','00','00','7E','81','89','89','4E','00','00','00',
      'FF','10','10','10','FF','00','00','00','81','81','FF','81','81','00','00','00','06','01','01','01',
      'FE','00','00','00','FF','18','24','42','81','00','00','00','FF','01','01','01','01','00','00','00','FF',
      '40','30','40','FF', '00','00','00','FF','40','30','08','FF','00','00','00','7E','81','81','81','7E','00','00',
      '00','FF','88','88','88','70','00','00','00','7E','81','85','82','7D','00','00','00','FF','88','8C','8A','71',
      '00','00','00','61','91','91','91','8E','00','00','00','80','80','FF','80','80','00','00','00','FE','01','01','01',
      'FE','00','00','00','F0','0C','03','0C','F0','00','00','00','FF','02','0C','02','FF','00','00','00','C3','24','18',
      '24','C3','00','00','00','E0','10','0F','10','E0','00','00','00','83','85','99','A1','C1','00','00','00','06','29',
      '29','29','1F','00','00','00','FF','09','11','11','0E','00','00','00','1E','21','21','21','12','00','00','00','0E',
      '11','11','09','FF','00','00','00','0E','15','15','15','0C','00','00','00','08','7F','88','80','40','00','00',
      '00','30','49','49','49','7E','00','00','00','FF','08','10','10','0F','00','00','00','00','00','5F','00','00','00',
      '00','00','02','01','21','BE','00','00','00','00','FF','04','0A','11','00','00','00','00','00','81','FF','01',
      '00','00','00','00','3F','20','18','20','1F','00','00','00','3F','10','20','20','1F','00','00','00','0E','11',
      '11','11','0E','00','00','00','3F','24','24','24','18','00','00','00','10','28','28','18','3F','00','00','00','1F',
      '08','10','10','08','00','00','00','09','15','15','15','02','00','00','00','20','FE','21','01','02','00','00','00',
      '1E','01','01','02','1F','00','00','00','1C','02','01','02','1C','00','00','00','1E','01','0E','01','1E','00','00',
      '00','11','0A','04','0A','11','00','00','00','00','39','05','05','3E','00','00','00','11','13','15','19','11','00',
      '00','00','00','41','FF','01','00','00','00','00','43','85','89','91','61','00','00','00','42','81','91','91','6E',
      '00','00','00','18','28','48','FF','08','00','00','00','F2','91','91','91','8E','00','00','00','1E','29','49','89',
      '86','00','00','00','80','8F','90','A0','C0','00','00','00','6E','91','91','91','6E','00','00','00','70','89','89',
      '8A','7C','00','00','00','60','80','8D','90','60','00','00','00','00','00','FD','00','00','00','00','00','7E','89',
      '91','A1','7E','00','00','00','66','89','8F','81','7E','00','00','00','24','FF','24','FF','24','00','00','00','76',
      '89','95','62','05','00','00','00','00','3C','42','81','00','00','00','00','00','81','42','3C','00','00','00','00',
      '08','08','3E','08','08','00','00','00','08','08','08','08','08','00','00','00','14','14','14','14','14','00','00',
      '00','10','10','54','38','10','00','00','00','08','1C','2A','08','08','00','00','00','12','2A','7F','2A','24','00',
      '00','00','44','02','12','02','44','00','00','00','FF','FF','FF','FF','FF','00','00','00','00','00','14','00','00',
      '00','00','00','00','00','02','00','00','00','00','00','00','00','00','00','00','00','00','00','00','00','02','03',
      '00','00','00','00'), byrow=TRUE, ncol=8)

  if (is.null(font_names))
    font_names <- c(LETTERS, letters,'1','2','3','4','5','6','7','8','9','?','!','0','@','#','&','(',')','"+"','-','=',
      'R arrow','L arrow','$','smile','5x8 block',':','.',' ',',')

  rownames(font) <- font_names

  convertHexToBinary <- function(x) regexpr(x, "0123456789ABCDEF")[[1]] - 1

  # locate the 8 by 8 grid corresponding to each letter in the message and create a stream of column descriptions
  msglocation <- sapply(strsplit(message, "")[[1]], function(x) head(grep(x, c(substr(rownames(font),1,1),x), fixed=TRUE)[1]))
  msglocation <- msglocation[msglocation <= nrow(font)] # skip any characters that are not in the font set
  msg <- c(head(t(font[msglocation,]), width))
  while(tail(msg,1) == "00") msg <- head(msg,-1)

  # convert each pair of Hexidecimal numbers into a decimal number and expand into its code for a column in an 8 by 8 grid
  messageColumns <- sapply(msg, function(x) convertHexToBinary(substr(x,1,1)) * 16 + convertHexToBinary(substr(x,2,2)))
  blockMsg <- sapply(messageColumns, function(x) sapply (0:7, function(i) trunc(x / 2^(7-i)) %% 2 == 1))
  blockMsg <- ifelse(blockMsg, symbols[1], symbols[2])

  # reverse rows and reverse columns to rotate 180 degrees
  if (rotate != 0) {
    block <- blockMsg
    for (i in 1:nrow(block))
      for (j in 1:ncol(block))
        blockMsg[i,j] <- block[nrow(block) - i + 1, ncol(block) - j + 1]
  }

  # convert the grid entries into X or blank and create a string for each of the 8 rows
  if (asData) {
    colnames(blockMsg) <- NULL
    return(blockMsg)
  }

  # return either portait or landscape text
  if (portrait) {
    rows <- matrix(apply(blockMsg, 1, function(x) paste(rep(x,each=repeats), collapse="")), ncol=1)
  } else {
    rows <- matrix(apply(blockMsg, 2, function(x) paste(rep(rev(x),each=repeats), collapse="")), ncol=1)
  }

  matrix(rep(rows,each=repeats), ncol = 1)

}