Maps of Global Crop Production
Maps of crop production using FAO data
Prepare Data
# devtools::install_github("derekmichaelwright/agData")
library(agData)
library(rworldmap)
Create new mapBubbles
Function
# Create plotting function
<- function (dF = "", nameX = "longitude", nameY = "latitude",
mapBubbles2 nameZSize = "", nameZColour = "", fill = TRUE, bg = NULL,
pch = 21, symbolSize = 1, maxZVal = NA, main = nameZSize,
numCats = 5, catMethod = "categorical", colourPalette = "heat",
xlim = NA, ylim = NA, mapRegion = "world", borderCol = "grey",
oceanCol = NA, landCol = NA, addLegend = TRUE, legendBg = "white",
legendVals = "", legendPos = "bottomright", legendHoriz = FALSE,
legendTitle = nameZSize, addColourLegend = TRUE, colourLegendPos = "bottomleft",
colourLegendTitle = nameZColour, add = FALSE, plotZeroVals = TRUE,
lwd = 0.5, lwdSymbols = 1, ...)
{<- as.character(sys.call()[[1]])
functionName if (class(dF) == "character" && dF == "") {
message(paste("using example data because no file specified in",
functionName))= getMap()@data
dF = "LON"
nameX = "LAT"
nameY if (nameZSize == "")
= "POP_EST"
nameZSize if (nameZColour == "")
= "continent"
nameZColour
}if (class(dF) == "SpatialPolygonsDataFrame") {
<- coordinates(dF)
centroidCoords "nameX"]] <- centroidCoords[, 1]
dF[["nameY"]] <- centroidCoords[, 2]
dF[[<- "nameX"
nameX <- "nameY"
nameY if (!add) {
rwmNewMapPlot(mapToPlot = dF, oceanCol = oceanCol,
mapRegion = mapRegion, xlim = xlim, ylim = ylim)
plot(dF, add = TRUE, border = borderCol, col = landCol,
main = main, lwd = lwd)
}<- dF@data
dF
}else if (!add) {
rwmNewMapPlot(mapToPlot = getMap(), oceanCol = oceanCol,
mapRegion = mapRegion, xlim = xlim, ylim = ylim)
plot(getMap(), add = TRUE, border = borderCol, col = landCol,
main = main, lwd = lwd)
}<- FALSE
singleColour if (nameZColour == "")
<- "red"
nameZColour if (is.na(match(nameZColour, names(dF)))) {
if (!tryCatch(is.matrix(col2rgb(nameZColour)), error = function(e) FALSE)) {
stop("your chosen nameZColour :'", nameZColour,
"' is not a colour and seems not to exist in your data, columns = ",
paste(names(dF), ""))
return(FALSE)
}else singleColour <- TRUE
}<- colourVector <- NA
cutVector if (!singleColour) {
<- dF[, nameZColour]
dataCategorised if (!is.numeric(dataCategorised) && catMethod != "categorical") {
= "categorical"
catMethod message(paste("using catMethod='categorical' for non numeric data in",
functionName))
}if (length(catMethod) == 1 && catMethod == "categorical") {
<- as.factor(dataCategorised)
dataCategorised <- levels(dataCategorised)
cutVector if (length(cutVector) > 15)
warning("with catMethod='categorical' you have > 15 categories, you may want to try a different catMethod, e.g. quantile")
}else {
if (is.character(catMethod) == TRUE) {
<- rwmGetClassBreaks(dataCategorised,
cutVector catMethod = catMethod, numCats = numCats, verbose = TRUE)
}else if (is.numeric(catMethod) == TRUE) {
<- catMethod
cutVector
}<- cut(dataCategorised, cutVector,
dataCategorised include.lowest = TRUE)
<- function(x, y) c(paste(x, "-", y[1 +
func which(y == x)], sep = ""))
<- sapply(cutVector, cutVector, FUN = func)
tmp <- tmp[1:length(tmp) - 1]
cutVector
}<- nameZColour
colNameRaw <- paste(colNameRaw, "categorised",
colNameCat sep = "")
<- dataCategorised
dF[[colNameCat]] <- length(levels(dataCategorised))
numColours <- rwmGetColours(colourPalette, numColours)
colourVector <- as.numeric(dataCategorised)
dataCatNums
}if (singleColour)
= nameZColour
col else col = colourVector[dataCatNums]
if (is.na(maxZVal))
<- max(dF[, nameZSize], na.rm = TRUE)
maxZVal = symbolSize * 4/sqrt(maxZVal)
fMult = fMult * sqrt(dF[, nameZSize])
cex points(dF[, nameX], dF[, nameY], pch = pch, cex = cex, col = col,
bg = bg, lwd = lwdSymbols)
if (addLegend && sum(as.numeric(abs(dF[, nameZSize])), na.rm = TRUE) !=
0) {
if (length(legendVals) > 1) {
<- fMult * sqrt(legendVals)
legendSymbolSizes
}else {
<- 3
sigFigs <- max(dF[, nameZSize], na.rm = TRUE)
maxVal <- min(dF[, nameZSize], na.rm = TRUE)
minVal <- c(signif(minVal, sigFigs), signif(minVal +
legendVals 0.5 * (maxVal - minVal), sigFigs), signif(maxVal,
sigFigs))<- fMult * sqrt(legendVals)
legendSymbolSizes
}= c(pch, pch, pch)
legendSymbolChars <- "black"
colour4LegendPoints if (plotZeroVals && legendSymbolSizes[1] == 0) {
1] <- 1
legendSymbolSizes[1] <- 3
legendSymbolChars[
}= symbolSize * 1.3
x.intersp = symbolSize * 1.3
y.intersp legend(x = legendPos, legend = legendVals, pt.cex = legendSymbolSizes,
pch = legendSymbolChars, col = colour4LegendPoints,
bg = legendBg, title = legendTitle, horiz = legendHoriz,
y.intersp = y.intersp, x.intersp = x.intersp)
}if (addColourLegend && !singleColour) {
addMapLegendBoxes(colourVector = colourVector, cutVector = cutVector,
x = colourLegendPos, title = colourLegendTitle)
}invisible(list(colourVector = colourVector, cutVector = cutVector))
}
Create custom plotting function ggCropMap
<- function(myCrop = "Lentils",
ggCropMap myMeasure = "Production",
myYear = 2019,
myFill = "darkgreen", myColor = "darkgreen",
myFilename = "crops_world_maps_lentils.png") {
# Prep data
<- agData_FAO_Crops %>%
xx filter(Item == myCrop,
== myYear,
Year == myMeasure,
Measurement %in% agData_FAO_Country_Table$Country) %>%
Area left_join(agData_FAO_Country_Table, by = c("Area"="Country"))
#
png(myFilename, width = 3600, height = 2055, res = 600)
par(mai = c(0.2,0,0.25,0), xaxs = "i", yaxs = "i")
mapBubbles2(dF = xx, nameX = "Lon", nameY = "Lat", nameZSize = "Value",
nameZColour = "darkgreen", bg = alpha("darkgreen",0.7),
symbolSize = 1, addLegend = F, lwd = 1,
#xlim = c(-140,110), ylim = c(5,20),
oceanCol = "grey90", landCol = "white", borderCol = "black")
title(main = paste(myMeasure, "-", myCrop,"-", myYear),
line = 0, cex = 3)
title(sub = "www.dblogr.com/ or derekmichaelwright.github.io/dblogr/ | Data: FAOSTAT",
line = 0, cex.sub = 0.75, adj = 1)
dev.off()
}
Wheat
ggCropMap(myCrop = "Wheat", myYear = 2019,
myMeasure = "Production",
myFilename = "crops_world_maps_wheat.png")
Maize
ggCropMap(myCrop = "Maize (corn)", myYear = 2019,
myMeasure = "Production",
myFilename = "crops_world_maps_maize.png")
Rapeseed
ggCropMap(myCrop = "Rapeseed or canola oil, crude", myYear = 2019,
myMeasure = "Production",
myFilename = "crops_world_maps_rapeseed.png")
Lentils
ggCropMap(myCrop = "Lentils, dry", myYear = 2019,
myMeasure = "Production",
myFilename = "crops_world_maps_lentils.png")
Chickpeas
ggCropMap(myCrop = "Chick peas, dry", myYear = 2019,
myMeasure = "Production",
myFilename = "crops_world_maps_chickpeas.png")
Peas
ggCropMap(myCrop = "Peas, dry", myYear = 2019,
myMeasure = "Production",
myFilename = "crops_world_maps_peas.png")
Beans
ggCropMap(myCrop = "Beans, dry", myYear = 2019,
myMeasure = "Production",
myFilename = "crops_world_maps_beans.png")
Soybeans
ggCropMap(myCrop = "Soya beans", myYear = 2019,
myMeasure = "Production",
myFilename = "crops_world_maps_soybeans.png")
Sugarbeet
ggCropMap(myCrop = "Sugar beet", myYear = 2019,
myMeasure = "Production",
myFilename = "crops_world_maps_sugarbeet.png")
Hempseed
ggCropMap(myCrop = "Hempseed", myYear = 2019,
myMeasure = "Production",
myFilename = "crops_world_maps_hempseed.png")
Potato
ggCropMap(myCrop = "Potatoes", myYear = 2019,
myMeasure = "Production",
myFilename = "crops_world_maps_potato.png")
Cotton
ggCropMap(myCrop = "Cotton seed", myYear = 2018,
myMeasure = "Production",
myFilename = "crops_world_maps_cotton.png")