R/convert.R

In moodymudskipper/tweak: Modifies PNG images

#' Convert one type of image to another
#'
#' Types are "raster","url","path","array3","matrix","long". See details
#'
#' @param img object to convert
#' @param to  type of output, defaults to raster
#' @param from type of input, guessed by default
#' @param path for to = "path"
#' @details
#' raster is a two dimensional raster object,
#' the format of the output of most tweak functions.
#'
#' url is the url to fetch, png, tif, jpg, webp and svg are supported.
#' Converting to url means uploading to imgur as PNG. To upload you'll need
#' an account, follow instructions when trying for the first time.
#' You can convert url to url, it's not a real copy though as it will
#' convert to png.
#'
#' path is the path to fetch, converting to path means saving.
#' By default you save to a temp file.
#' You can convert path to path
#'
#' array3 is a numeric three dimensional raster object,
#' that we get when importing the files
#'
#' matrix is a character two dimensional matrix containing rgba colors in hex
#'
#' long is a numeric matrix with 4 columns (rgba) and a DIM attribute
#'
#' @export
convert <- function(img,
                    to   = c("raster","url","path","array3","matrix","long"),
                    from = c("auto","raster","url","path","array3","matrix","long"),
                    path = NULL){
  to  <-match.arg(to)
  from  <-match.arg(from)
  types <- c("url","path","array3","raster","matrix","long")
  if(from == "auto") from <- guess_format(img)
  from = match(from,types)
  to   = match(to  ,types)
  funs <- list(
    url2url , url2pth , url2arr , url2rst  , url2mat  ,url2lng,
    pth2url , pth2pth , pth2arr , pth2rst  , pth2mat  ,pth2lng,
    arr2url , arr2pth , identity, arr2rst  , arr2mat  ,arr2lng,
    rst2url , rst2pth , rst2arr , identity , as.matrix,rst2lng,
    mat2url , mat2pth , mat2arr , as.raster, identity ,mat2lng,
    lng2url , lng2pth , lng2arr , lng2rst  , lng2mat  ,identity)
  fun <- funs[[(from-1)*length(types)+to]]
  if (to == "path") fun(img,path) else fun(img)
}

guess_format <- function(x){
  if(is.character(x) && length(x) == 1)
  {if(is_url(x)) "url" else           "path"}  else
    if(length(dim(x))==3)             "array3" else
      if(is.raster(x))                "raster" else
        if(!is.null(attr(x,"DIM"))) "long"   else
        if(is.matrix(x))              "matrix" else
            stop("Couldn't detect format")
}

is_url <- function(x){
  if(!is.character(x) || length(x) != 1) return(FALSE)
  if(substr(x,1,7) == "http://") TRUE else
    if(substr(x,1,8) == "https://") TRUE else
      if(substr(x,1,6) == "ftp://") TRUE else
        if(substr(x,1,7) == "file://") TRUE else
          FALSE
}

#### url ####
url2url <- function(url){
  if(tolower(tools::file_ext(url)) == "png")
    pth2url(url2pth(url)) else
      arr2url(url2arr(url))
}
url2pth <- function(url,pth=NULL){
  if(is.null(pth)) pth <- tempfile(fileext = paste0(".",tools::file_ext(url)))
  download.file(url,pth,mode = "wb")
  pth
}
url2arr <- function(url) pth2arr(url2pth(url))
url2mat <- function(url) lng2mat(url2lng(url))
url2rst <- function(url) as.raster(lng2mat(url2lng(url)))
url2lng <- function(url) pth2lng(url2pth(url))

#### path ####
pth2pth <-function(pth,pth2=NULL){
  if(is.null(pth2)) return(pth)
  arr2pth(pth2arr(pth),pth2)
}
pth2url <- function(pth){
  if(tolower(tools::file_ext(pth)) == "svg")
    pth <- pth2pth(pth,gsub(".svg",".png",pth))
  token = imguR::imgur_login()
  url <- imguR::upload_image(token=token,file = pth)$link
  url
}

pth2arr <- function(pth) {
  if(tolower(tools::file_ext(pth)) == "webp")
    return(webp::read_webp(pth))
  if(tolower(tools::file_ext(pth)) == "svg"){
    new_pth <- gsub(".svg",".png",pth)
    rsvg::rsvg_png(pth,new_pth)
    pth <- new_pth
  }
  OpenImageR::readImage(pth)}

pth2mat <- function(pth) lng2mat(pth2lng(pth))
pth2rst <- function(pth) as.raster(lng2mat(pth2lng(pth)))
pth2lng <- function(pth) arr2lng(pth2arr(pth))

#### array3 ####
arr2url <- function(arr) pth2url(arr2pth(arr))
arr2pth <- function(arr,pth=NULL){
  if(is.null(pth)) pth <- tempfile(fileext = ".PNG")
  png::writePNG(arr,pth)
  pth
}
arr2mat <- function(arr) lng2mat(arr2lng(arr))
arr2rst <- function(arr) lng2rst(arr2lng(arr))
arr2lng <- function(arr){
  lng <- apply(arr,3,c)
  if(ncol(lng)==3) lng <- cbind(lng,1)
  attr(lng,"DIM") <- c(dim(arr)[1],dim(arr)[2])
  lng
}

#### matrix ####
mat2url <- function(mat) pth2url(mat2pth(mat))
mat2pth <- function(mat,pth=NULL) arr2pth(mat2arr(mat),pth)
mat2arr <- function(mat) lng2arr(mat2lng(mat))
mat2lng <- function(mat){
  lng <- c(as.matrix(mat))
  lng <- cbind(as.numeric(as.hexmode(substr(lng,2,3)))/255,
                as.numeric(as.hexmode(substr(lng,4,5)))/255,
                as.numeric(as.hexmode(substr(lng,6,7)))/255,
                as.numeric(as.hexmode(substr(lng,8,9)))/255)
  attr(lng,"DIM") <- c(dim(mat)[1],dim(mat)[2])
  lng
}

#### raster ####
rst2url <- function(rst) pth2url(rst2pth(rst))
rst2pth <- function(rst,pth=NULL) arr2pth(rst2arr(rst),pth)
rst2arr <- function(rst) lng2arr(rst2lng(rst))
rst2lng <- function(rst) mat2lng(as.matrix(rst))

#### long matrix ####
lng2url <- function(lng) pth2url(lng2pth(lng))
lng2pth <- function(lng,pth=NULL) arr2pth(lng2arr(lng),pth)
lng2arr <- function(lng) array(lng,dim=c(attr(lng,"DIM")[1],attr(lng,"DIM")[1],4))
lng2mat <- function(lng){
  mat <- matrix(rgb(lng[,1],lng[,2],lng[,3],lng[,4], maxColorValue=1),
                nrow=attr(lng,"DIM")[1],
                ncol=attr(lng,"DIM")[2],
                byrow=FALSE)
  mat
}
lng2rst <- function(lng) as.raster(lng2mat(lng))