R/from_coord_polygon.R

In cartogramR: Continuous Cartogram

#' Transform from coordinates system used in the polygons to coordinates
#' system used in flow based cartogram
#' 
#' Apply the mapping from the coordinates system used in the polygons
#'   (caracterised by the CRS) to the coordinates system used in flow based cartogram
#'
#' @param coord a vector of length 2 or a two columns matrix containing xy
#'     coordinates to transform
#' @param carto a cartogramR object
#'
#' @return a vector of length 2 or a two columns matrix containing xy
#'    coordinates in the coordinate systems of polygons used to build
#'    the cartogram
#'
#' @export
#' @examples
#'  \donttest{
#'   data(usa)
#'   carto <- cartogramR(usa, "electors64")
#'   from_coord_polygon(c(-0.007, -0.348), carto)
#'  }
#'
#'
#' @md
from_coord_polygon <- function(coord, carto) {
    if (!inherits(carto, "cartogramR"))
        stop("carto not inherits from cartogramR class")
    if (!is.numeric(coord))
        stop("coordinates must be numeric")
    if (is.vector(coord)) {
        if (length(coord)!=2) 
            stop("coordinates must be a vector of length 2 or a two columns matrix containing xy coordinates")
        coord <- matrix(coord, ncol=2, nrow=1)
    }
    if (is.matrix(coord)) {
        if (ncol(coord)!=2) 
            stop("coordinates must be a vector of length 2 or a two columns matrix containing xy coordinates")
    }
    LL <-  attr(carto,"options")$paramsint[1]
    padding <- attr(carto,"options")$paramsdouble[3]
    bbox <- attr(carto, "initial_bbox")
    Delta <- c(diff(bbox[c(1,3)]), diff(bbox[c(2,4)]))
    gg <- c(sum(bbox[c(1,3)]), sum(bbox[c(2,4)]))/2
    mm <- gg - Delta/2 * padding
    MM <- gg + Delta/2 * padding
    biggest <- which.max(MM-mm)
    smallest <- which.min(MM-mm)
    scale <- (MM[biggest]-mm[biggest])/LL
    newmmB <- gg[biggest] - 0.5*LL*scale
    lxy <- 2^(ceiling(log2((MM[smallest]-mm[smallest])/scale)))
    newmmS <- gg[smallest] - 0.5*lxy*scale
     if (biggest==1) {
         coord <- sweep(coord,2,c(newmmB,newmmS),FUN="-")
     } else {
         coord <- sweep(coord,2,c(newmmS,newmmB),FUN="-")
     }
    coord <- sweep(coord,2,rep(scale,2),FUN="/")
    return(coord)
}