1bubbleMap <- structure(function#Create a bubble plot of spatial data on Google Maps
2### This function creates a bubble plot of spatial
3### data, with options for bicolour residual plots.
4(
5  SP, ##<< object of class data.frame or \link[sp]{SpatialPointsDataFrame-class} with associated coordinate reference systems
6  coords=c("x", "y"), ##<< names of coordinate columns
7  crs=sp::CRS("+proj=longlat +datum=WGS84") , ##<< coordinate reference systems
8  map, ##<< map object; if missing map is downloaded from server
9  filename = "", ##<< filename to save the map under, IF map object not given
10  zcol = 1, ##<< variable column name, or column number after removing spatial coordinates from x@data: 1 refers to the first non-coordinate column
11  max.radius = 100, ##<< value for largest circle (the plotting symbols) in metre, circumcircle of triange or quadrangle (square)
12  key.entries, ##<< value for largest circle (the plotting symbols) in metre, circumcircle of triange or quadrangle (square)
13  do.sqrt = TRUE,##<< logical; if TRUE the plotting symbol area (sqrt(diameter)) is proportional to the value of the z-variable; if FALSE, the symbol size (diameter) is proportional to the z-variable
14#  add = FALSE, ##<< logical; if TRUE the result of the function will be a list stored as variable  in  R. It is possible to combine more layers in the one plot, previously saved output from plotGoogleMaps should be given in the previousMap attribute.
15#  previousMap = NULL,##<<
16  colPalette = NULL, ##<< colours to be used to fill plotting symbols; numeric vector of same size like key.entries
17  strokeColor = "#FFAA00", ##<< the color to draw the border of circle (the plotting symbols)
18  alpha = 0.7, ##<< the fill opacity between 0.0 and 1.0
19  strokeWeight = 1, ##<< the stroke width in pixels
20  LEGEND = TRUE, ##<< logical; if TRUE add bubbleLegend
21  legendLoc = "topleft", ##<< the x and y co-ordinates to be used to position the legend. They can be specified by keyword or in any way which is accepted by \code{legend}
22  verbose =0 ##<< level of verbosity
23){
24  ####################################################################
25  if (missing(key.entries)) key.entries = round(quantile(SP@data[,zcol], (1:5)/5),1)
26  PolyCol <-   function#Create list of colors depending on attribute data. (for bubbleMap)
27  (attribute, ##<< vector of attribute data
28   colPalette=NULL, ##<< colours to be used to fill features depending on attribute
29   at ##<< values at which colours will change
30  ) {
31    # attribute=soil.ll@data$ID
32    pal<-colorRampPalette(c( "green", "orange","brown"), space = "Lab")
33
34    if(!is.numeric(attribute)){ attribute<-as.factor( attribute)}
35
36    if(length(colPalette)==1) {
37      x<- rep(colPalette,length(attribute))
38      col.data<-list(cols=as.character(substr(x,1,7)),col.uniq=colPalette, att=ifelse(!is.factor(attribute),paste("[",min(attribute)," , ",max(attribute),"]",sep=""), " "))
39      return(col.data) }
40
41    if(is.null(colPalette) ){
42      colPalette<-pal(min(10,length(attribute) ) ) }else{ xx<-colPalette<-as.character(substr(colPalette,1,7)) }
43
44    if(is.factor(attribute)){
45
46      if(length(colPalette)!=nlevels(attribute)) {
47        xx<-colPalette<- as.character(substr(pal(nlevels(attribute)),1,7))    }
48
49      x<-factor(attribute,labels=colPalette)
50      col.data<-list(cols=as.character(substr(x,1,7)),col.uniq=colPalette, att=levels(attribute) )
51      return(col.data)
52
53    }else{
54      bre<-quantile(attribute, seq(1,length(colPalette))/length(colPalette))
55      breakss<-factor(c(min(attribute),bre))
56      break_unique<-as.numeric(levels(breakss))
57
58      if(length(colPalette)>=length(break_unique)){
59        colPalette<-colPalette[1:length(break_unique)] } else{
60          colPalette<- as.character(substr(colPalette[1:length(break_unique)-1],1,7))}
61
62      atr<-cut(attribute, break_unique ,include.lowest = TRUE, dig.lab=6)
63      x<-factor(atr,labels=colPalette[1:(length(break_unique)-1)] )
64      col.data<-list(cols=as.character(substr(x,1,7)),col.uniq=colPalette, att=levels(atr) )
65      return(col.data)
66
67    }
68
69    ###The function provide list of colors (cols), unique colors (col.uniq), levels of attribute (att),attribute breaks (brks).
70  }
71    #require(rgdal)
72  if (class(SP) == "data.frame") {
73    #SP = DF2SpatialPointsDataFrame(SP, coords=c("x", "y"))
74    nameOfSP = deparse(substitute(SP))
75    z = SP[, zcol]
76    ll = SP[, coords]
77  } else {
78    stopifnot(class(SP) == "SpatialPointsDataFrame")
79    obj = as(SP, "SpatialPointsDataFrame")
80    data = obj@data
81    if (NCOL(data) == 1) {
82      z = data
83    }
84    else {
85      z = data[, zcol]
86    }
87    SP.ll <- sp::spTransform(SP, crs)
88    Centar = c(mean(SP.ll@bbox[1, ]), mean(SP.ll@bbox[2, ]))
89    sw <- c(SP.ll@bbox[2, 1], SP.ll@bbox[1, 1])
90    ne <- c(SP.ll@bbox[2, 2], SP.ll@bbox[1, 2])
91    nameOfSP <- sapply(as.list(substitute({
92      SP
93    })[-1]), deparse)
94    nameOfSP <- gsub("[!,\",#,$,%,&,(,),*,+,-,.,/,:,;,<,=,>,?,@,^,`,|,~]",
95                     "_", nameOfSP)
96    nameOfSP <- gsub("[[]", "_", nameOfSP)
97    nameOfSP <- gsub("[]]", "_", nameOfSP)
98
99    attribute = SP@data[, zcol]
100    for (i in 1:length(SP.ll@data)) {
101      if (identical(attribute, SP.ll@data[, i])) {
102        attributeName <- names(SP.ll@data)[i]
103      }
104    }
105    ll = SP.ll@coords
106  }
107  att <- rep(NA, length(ll[, 1]))
108  att1 = ""
109  if (filename == "") {
110    filename <- paste(nameOfSP, ".png", sep = "")
111  }
112    if (min(key.entries) < 0) {
113        ke <- abs(min(key.entries)) + key.entries + mean(key.entries)
114    }
115    else {
116        ke <- key.entries + mean(key.entries)
117    }
118    if (do.sqrt) {
119        scale.level <- sqrt(ke/(max(ke)))
120    }
121    else {
122        scale.level <- ke/(max(ke))
123    }
124    radius.level <- max.radius * scale.level
125    breakss <- factor(c(min(z), key.entries))
126    break_unique <- as.numeric(levels(breakss))
127    if (length(unique(z)) == length(key.entries)) {
128        zz = factor(z, labels = radius.level)
129        radius.vector <- floor(as.numeric(as.vector(zz)))
130    }
131    else {
132        zz = factor(cut(z, break_unique, include.lowest = TRUE),
133            labels = radius.level)
134        radius.vector <- floor(as.numeric(as.vector((zz))))
135    }
136
137#     polyName <- paste("poly", nameOfSP, sep = "")
138#     boxname <- paste(nameOfSP, "box", sep = "")
139#     textname <- paste(nameOfSP, "text", sep = "")
140#     divLegendImage <- tempfile("Legend")
141#     divLegendImage <- substr(divLegendImage, start = regexpr("Legend",
142#         divLegendImage), stop = nchar(divLegendImage))
143#     legendboxname <- paste("box", divLegendImage, sep = "")
144#     textnameW <- paste(textname, "W", sep = "")
145
146    if (strokeColor != "") {
147        rgbc <- col2rgb(strokeColor)
148        strokeColor <- rgb(rgbc[1], rgbc[2], rgbc[3], maxColorValue = 255)
149    }
150    if (!is.null(colPalette)) {
151        rgbc <- col2rgb(colPalette)
152        colPalette <- apply(rgbc, 2, function(x) rgb(x[1], x[2],
153            x[3], maxColorValue = 255))
154    }
155
156    cxx <- PolyCol(factor(zz, labels = key.entries), colPalette)
157    plotclr <- cxx$cols
158    plotclr = AddAlpha(plotclr,alpha)
159
160    bb <- qbbox(lat = ll[, 2], lon = ll[, 1]);
161    if (verbose>1) browser()
162    ##download the map:
163    if (missing(map))
164      map <- GetMap.bbox(bb$lonR, bb$latR, destfile = filename, maptype="mobile", SCALE = 2);
165    PlotOnStaticMap(map, lat = ll[, 2], lon = ll[, 1],
166                    col = plotclr, cex = 3*radius.vector/max(radius.vector, na.rm=TRUE), pch = 20)
167    if (LEGEND) {
168      CEX = sqrt(as.numeric(key.entries))
169      CEX = 4*CEX/max(CEX)
170      cxx2 <- PolyCol(factor(CEX, labels = key.entries), colPalette)
171      LEGEND = paste0("<",as.character(key.entries))
172      legend(legendLoc, pt.cex=CEX,col=cxx2$cols, pch=20, legend=LEGEND)
173    }
174invisible(map)
175#####################################################################
176### map structure or URL used to download the tile.
177}, ex = function(){
178
179  if (0) {
180    data(lat.lon.meuse, package="loa", envir = environment())
181
182    map <- GetMap(center=c(lat=50.97494,lon=5.743606), zoom=13,
183           size=c(480,480),destfile = file.path(tempdir(),"meuse.png"),
184            maptype="mobile", SCALE = 1);
185
186    par(cex=1.5)
187    bubbleMap(lat.lon.meuse, coords = c("longitude","latitude"), map=map,
188          zcol='zinc', key.entries = 100+ 100 * 2^(0:4));
189  }
190
191})
192
193
194