R/utils.R

In lgsilvaesilva/spGoogle: Interacting R with Google maps: Spatial visualization tool

###########################################################################################
## Set Weights
###########################################################################################
set.wei <- function(data,var){
 if(length(var) == 0) wei <- NULL
 else {
        if(length(names(data@data) == var) > 0) wei <- data@data[,var]
        else{}
        }
 wei
}

###########################################################################################
## Set plot variables
###########################################################################################
set.var <- function(wei,decimals,prob,nam, under = 'under', over = 'over', between = '-'){
  if(length(wei)>0)
   {
      if(is.numeric(wei)){ 
   	   brks    <- prob
   	   #nclr    <- length(brks) - 1
  	   plotclr <- nam     ## http://colorbrewer2.org/
           #nclr    <- min(nclr,length(plotclr))
  	   vcol    <- plotclr[ findInterval(wei,brks) ]
  	   vsize   <- (findInterval(wei,brks)/max(findInterval(wei,brks)) + 1) 
  	   leg     <- leglabs(round(brks,decimals), under = under, over = over, between = between)
  	 }
  	 else{ 
  	   wei     <- as.factor(wei)
   	   #nclr    <- length(levels(wei))
  	   plotclr <- nam     ## http://colorbrewer2.org/
           #nclr    <- min(nclr,length(plotclr))
  	   #nclr    <- length(levels(wei))
  	   #if(length(nam) == 1) plotclr <- brewer.pal(nclr,nam)     ## http://colorbrewer2.org/
  	   #else plotclr <- nam     ## http://colorbrewer2.org/
           #nclr    <- min(nclr,length(plotclr))
  	   vcol    <- plotclr[ match(wei,levels(wei)) ]
  	   vsize   <- 1 #match(wei,levels(wei))
  	   leg     <- as.character(levels(wei))
  	 }
  }
  else{
  	   vcol    <- nam[1]
  	   vsize   <- 1
           leg     <- NULL
           plotclr <- vcol
  }   
  
  return(list(vcol=vcol,vsize=vsize,cols=plotclr,leg=leg))
}

###########################################################################################
## Plot Polygons
###########################################################################################
plot.poly <- function(data, var, decimals, maptype, cuts, col.pallete, add, cuts.type, legend.att, border = NULL, zoom = NULL, ...)
{
  box <- data@bbox
 wei <- set.wei(data,var)

 if(is.numeric(wei)){ 
   if(length(cuts) == 1) prob <- genprob(wei,cuts,cuts.type)
   else prob <- cuts
 }
 
 ch.var <- set.var(wei, decimals, prob, col.pallete, 
                   under = ifelse(is.null(legend.att$under), 'under', legend.att$under), 
                   over = ifelse(is.null(legend.att$over), 'over', legend.att$over), 
                   between = ifelse(is.null(legend.att$between), '-', legend.att$between))
 
 legend.att['between'] <- NULL
 legend.att['under'] <- NULL
 legend.att['over'] <- NULL
 
 legend.default <- list(x = "bottomright", legend = ch.var$leg, fill = ch.var$cols, cex = 1, ncol = 1, bty = "n")
 legend.default[names(legend.att)] <- NULL
 legend.list <- c(legend.att, legend.default)
  ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ##
 ## Plota o mapa no mapa do Google Maps	
 #maptype  <- 'satellite'	##'terrain', 'roadmap', 'satellite', 'hybrid'
 n_pix    <- 640
 destfile <- 'TemporaryMap.png'

 if (is.null(zoom)) {
   zoom <- min(MaxZoom(range(box[1,]), range(box[2,]))) 
 }
 
 map <- GetMap.bbox(box[1,], box[2,], format = 'png', maptype = maptype, 
                    destfile = destfile, zoom = zoom)		## png

 
 PlotOnStaticMap(map,add=add)
 PlotPolysOnStaticMap(map, SpatialPolygons2PolySet(data), lwd=.5, col = ch.var$vcol, border=border, ...)
 
 if((!add) & (length(wei) > 0)) do.call(legend, legend.list)
 invisible(file.remove(c("TemporaryMap.png","TemporaryMap.png.rda")))
}

###########################################################################################
## Plot Points
###########################################################################################
plot.points <- function(data, var, decimals, maptype, cuts, col.pallete, add, cuts.type, legend.att, zoom = NULL, ...)
{
  box <- data@bbox
  
  wei <- set.wei(data,var)

 if(is.numeric(wei)){ 
   if(length(cuts) == 1) prob <- genprob(wei,cuts,cuts.type)
   else prob <- cuts
 }
   
  ch.var <- set.var(wei, decimals, prob, col.pallete, 
                    under = ifelse(is.null(legend.att$under), 'under', legend.att$under), 
                    over = ifelse(is.null(legend.att$over), 'over', legend.att$over), 
                    between = ifelse(is.null(legend.att$between), '-', legend.att$between))
  
  legend.att['between'] <- NULL
  legend.att['under'] <- NULL
  legend.att['over'] <- NULL
  
  legend.default <- list(x = "bottomright", legend = ch.var$leg, fill = ch.var$cols, cex = 1, ncol = 1, bty = "n")
  legend.default[names(legend.att)] <- NULL
  legend.list <- c(legend.att, legend.default)
  
   ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ##
   ## Plota o mapa no mapa do Google Maps	
   #maptype  <- 'satellite'	##'terrain', 'roadmap', 'satellite', 'hybrid'
   n_pix    <- 640
   destfile <- 'TemporaryMap.png'

   if (is.null(zoom)) {
     zoom <- min(MaxZoom(range(box[1,]), range(box[2,]))) 
   }
   
   map <- GetMap.bbox(box[1,], box[2,], format = 'png', maptype = maptype, 
                         destfile = destfile, zoom=zoom)		## png

   #PlotOnStaticMap(map)
   PlotOnStaticMap(map,data@coords[,2],data@coords[,1], cex=ch.var$vsize, pch=20, col = ch.var$vcol, add = add, ...)
   ## Inserir Legenda
   if((!add) & (length(wei) > 0)) do.call(legend, legend.list)
   invisible(file.remove(c("TemporaryMap.png","TemporaryMap.png.rda")))
}
###########################################################################################
## Plot Pixel
###########################################################################################
plot.pixel <- function(data, var, decimals, maptype, cuts, col.pallete,add,cuts.type, legend.att, zoom = NULL, ...)
{
  box <- data@bbox

  if((class(data) == "SpatialGridDataFrame")){
       data <- as(data,"SpatialPixelsDataFrame")
       var <- names(data@data)
  }
  if((class(data) == "SpatialGrid")) data <- as(data,"SpatialPixels")
  
 
  if((class(data) == "SpatialPixelsDataFrame")) spol <- as(data, "SpatialPolygonsDataFrame") 
  else spol <- as(data, "SpatialPolygons") 

  spol@bbox <- box
  
  plot.poly(spol,var,decimals,maptype, cuts, col.pallete, add, cuts.type, border=NA, legend.att, zoom, ...)
}

###########################################################################################
## Plot kernel
###########################################################################################
#' @importFrom sp SpatialPoints points2grid SpatialGridDataFrame
plot.im <- function(data, var, decimals, maptype, cuts, col.pallete,add,cuts.type, legend.att, zoom = NULL, ...)
{
  sp.point <- SpatialPoints(cbind(data$xcol, data$yrow))
  sp.grid <- points2grid(sp.point)
  
  mat <- t(data$v)
  for(i in 1:nrow(mat)) mat[i,] <- mat[i,ncol(mat):1]
  w <- as.vector(mat)
 
  sp.grid <- SpatialGridDataFrame(sp.grid, data.frame(val=w))
  spix <- as(sp.grid, "SpatialPixelsDataFrame")
  spol <- as(spix, "SpatialPolygonsDataFrame") 
  
  plot.poly(spol,names(spol@data)[1],decimals,maptype, cuts, col.pallete, add, cuts.type, border=NA, legend.att, zoom, ...)
}


###########################################################################################
## Plot Lines
###########################################################################################
#' @importFrom sp coordinates
plot.line <- function(data, var, decimals, maptype, cuts, col.pallete, add, cuts.type, lwd = 1.5, legend.att, zoom = NULL, ...)
{
  box <- data@bbox
  wei <- set.wei(data,var)
  
  if(is.numeric(wei)){ 
    if(length(cuts) == 1) prob <- genprob(wei,cuts,cuts.type)
    else prob <- cuts
  }
  
  ch.var <- set.var(wei, decimals, prob, col.pallete, 
                    under = ifelse(is.null(legend.att$under), 'under', legend.att$under), 
                    over = ifelse(is.null(legend.att$over), 'over', legend.att$over), 
                    between = ifelse(is.null(legend.att$between), '-', legend.att$between))
  
  legend.att['between'] <- NULL
  legend.att['under'] <- NULL
  legend.att['over'] <- NULL
  
  legend.default <- list(x = "bottomright", legend = ch.var$leg, fill = ch.var$cols, cex = 1, ncol = 1, bty = "n")
  legend.default[names(legend.att)] <- NULL
  legend.list <- c(legend.att, legend.default)
  
  if(is.null(var)){
    ch.var$vcol <- rep(ch.var$vcol, nrow(data))
  }
  ## - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ##
  ## Plota o mapa no mapa do Google Maps	
  #maptype  <- 'satellite'	##'terrain', 'roadmap', 'satellite', 'hybrid'
  n_pix    <- 640
  destfile <- 'TemporaryMap.png'
  
  if (is.null(zoom)) {
    zoom <- min(MaxZoom(range(box[1,]), range(box[2,]))) 
  }
  
  map <- GetMap.bbox(box[1,], box[2,], format = 'png', maptype = maptype, 
                     destfile = destfile, zoom = zoom)		## png
  
  
  coordLines <- coordinates(data)
  if(!add){
    PlotOnStaticMap(map, coordLines[[1]][[1]][,2], coordLines[[1]][[1]][,1], lwd = lwd, col = ch.var$vcol[1], add = F, FUN = lines, ...)
    for(i in 2:nrow(data)) {
      PlotOnStaticMap(map, coordLines[[i]][[1]][,2], coordLines[[i]][[1]][,1], lwd = lwd, col = ch.var$vcol[i], add = T, FUN = lines, ...)
    }  
  }else{
    for(i in 1:nrow(data)) {
      PlotOnStaticMap(map, coordLines[[i]][[1]][,2], coordLines[[i]][[1]][,1], lwd = lwd, col = ch.var$vcol[i], add = T, FUN = lines, ...)
    }
  }
  
  if((!add) & (length(wei) > 0)) do.call(legend, legend.list)
  invisible(file.remove(c("TemporaryMap.png","TemporaryMap.png.rda")))
}

#################
spGoogle.httpd.handler <- function(path, query, ...) {
  
  # path <- gsub("^/custom/spGoogle/", "", path)
  dir_serv <- gsub("^/custom/spGoogle/", "", dirname(path))
  path <- basename(path)
  
  f <- sprintf("%s%s%s",
               dir_serv,
               .Platform$file.sep,
               path) 
  list(file=f,
       "content-type"="text/html",
       "status code"=200L)
}

##-------------------------------------------------##

#' @title Modify a spGoogle object by adding on new components.
#' @description This operator allows you to add objects to a spGoogle object.
#' @param e1 object of the spGoogle class
#' @param e2 object of the spGoogle class
#' @param ... further arguments passed to or from other methods.
#' 
#' @exportMethod + spGoogle
#' @export
"+.spGoogle" <- function(e1, e2, ...) {
  sp2name <- deparse(substitute(e2))
  merge_spGoogle(e1, sp2name, ...)
}


#' @title Invisible print to spGoogle objects.
#' @description Invisibly returns the result of spGplot 
#' which is a list with components that contain the kml and legend path.
#' @param x object of the spGoogle class
#' @param ... further arguments passed to or from other methods.
#' @exportMethod print spGoogle
#' @export
print.spGoogle <- function(x, ...) {
  invisible(x)
}

#' @title Merge spGoogle objects
#' @description Merge spGoogle objects
#' @param sp1 object of the spGoogle class
#' @param spgoogleCall list of paramters
#' @param ... further arguments passed to or from other methods.
#' @importFrom tools startDynamicHelp
#' @export
merge_spGoogle <- function(sp1, spgoogleCall, ...) {
  sp2 <- eval(parse(text=spgoogleCall)) 
  output_spgoogle <- list(sp1, sp2)
  kml_path     <- list(sp1$kmlpath, sp2$kmlpath)
  kml_parse    <- lapply(kml_path, xmlTreeParse)
  kml_document <- lapply(kml_parse, function(kml) kml$doc$children$kml[[1]])
  kml_merged   <- Reduce(f = function(...) append.XMLNode(...), list(kml_parse[[1]]$doc$children$kml, kml_document[-1]))
  
  kml_merged_name <- tempfile(pattern = 'MERGED_KML_', fileext = '.kml')
  kml_path <- file.path(dirname(sp1$kmlpath), basename(kml_merged_name))
  saveXML(kml_merged, file = kml_path)
  path <- list(kmlpath = kml_path, leg.path = sp1$leg.path)
  
  html_read <- readLines(sp1$html_path)
  pos_leg <- grep('legenda', readLines(sp1$html_path))
  leg1 <- html_read[pos_leg]
  leg2 <- add_legend(leg = sp2$leg.path, tempdir = '.')
  leg_final <- paste(c(leg1, leg2), collapse = ' ', sep = '')
  html_read[pos_leg] <- leg_final
  
  pos_kml <- grep('kml', html_read)
  html_read[pos_kml] <- gsub("\\(.*\\)", replacement = sprintf("(\'%s\')", basename(kml_path)), html_read[pos_kml])
  
  path.map <- sp1$html_path
  
  html <- file(path.map, open = 'w')
  cat(html_read, sep = '\n', file = html)
  close(html)
  
  if(!isServerRunning() ) {
    startDynamicHelp()
  }
  
  env <- get( ".httpd.handlers.env", asNamespace("tools"))
  env[["spGoogle"]] <- spGoogle.httpd.handler
  
  .url <- sprintf("http://127.0.0.1:%s/custom/spGoogle/%s",
                  ifelse(R.version['svn rev'] < 67550 | getRversion() < "3.2.0",
                         get("httpdPort", envir=environment(startDynamicHelp)),
                         tools::startDynamicHelp(NA)
                  ),
                  path.map)
  
  viewer <- getOption("viewer")
  if (!is.null(viewer))
    viewer(.url)
  else
    utils:: browseURL(.url)
  
  out <- c(path, html_path = path.map)
  class(out) <- 'spGoogle'
  invisible(out)
}

isServerRunning <- function() {
  ifelse(R.version['svn rev'] < 67550 | getRversion() < "3.2.0",
         get("httpdPort", envir = environment(startDynamicHelp))>0,
         tools::startDynamicHelp(NA)>0
  )
}


add_legend <- function(leg, tempdir) {
  if (!is.na(leg)) {
    leg <- basename(leg)
    legend_string <- paste('<img src=\"', tempdir, "/", leg, '\">', sep = "")
  } else {
    legend_string <- ''
  }
  return(legend_string)
}


MakeBall <- function(col, radius, file, width, height, sizeMin = 0.5, sizeMax = 1){
  x0 <- 0
  y0 <- 0
  r  <- radius
  t  <- seq(0, 2*pi, length.out = 360)
  x <- x0 + r*cos(t)
  y <- y0 + r*sin(t)
  
  x <- c(x[length(x)],x, x[length(x)])
  y <- c(y[length(y)],y, y[length(y)])
  
  png(filename = file, width, height, bg="#FFFFFF00")
  op <- par(bg="transparent", oma = c(0, 0, 0, 0), mar = rep(0, 4))
  plot(0,0, col="white", axes=F, col.axis = "white", xlab = "",ylab = "", xlim = c(-sizeMax, sizeMax), ylim = c(-sizeMax, sizeMax))
  polygon(x,y, col = col)
  dev.off()
}

LegendBubble <- function(col, radius, width, height){
  x0 <- 0
  y0 <- 0
  t  <- seq(0, 2*pi, length.out = 360)
  r <- sort(radius, decreasing = TRUE)
  x <- lapply(r, FUN = function(x) x0 + x*cos(t))
  y <- lapply(r, FUN = function(x) x0 + x*sin(t))
  
  x <- lapply(x, FUN = function(x) c(x[length(x)],x, x[length(x)]))
  y <- lapply(y, FUN = function(y) c(y[length(y)],y, y[length(y)]))
  
  for (i in 1:length(y)){
    y[[i]] <- y[[i]] - (max(r) - r)[i]
  }
  
  # png(filename = "xx.png", width, height, bg="#FFFFFF00")
  op <- par(bg="transparent", oma = c(0, 0, 0, 0), mar = rep(0, 4))
  plot(0,0, col="white", axes=F, col.axis = "white", xlab = "",ylab = "", asp = 1)
  mapply(polygon, x,y, col = col)
  # dev.off()
}