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
mapBubbles2 <- function (dF = "", nameX = "longitude", nameY = "latitude", 
    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, ...) 
{
    functionName <- as.character(sys.call()[[1]])
    if (class(dF) == "character" && dF == "") {
        message(paste("using example data because no file specified in", 
            functionName))
        dF = getMap()@data
        nameX = "LON"
        nameY = "LAT"
        if (nameZSize == "") 
            nameZSize = "POP_EST"
        if (nameZColour == "") 
            nameZColour = "continent"
    }
    if (class(dF) == "SpatialPolygonsDataFrame") {
        centroidCoords <- coordinates(dF)
        dF[["nameX"]] <- centroidCoords[, 1]
        dF[["nameY"]] <- centroidCoords[, 2]
        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 <- dF@data
    }
    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)
    }
    singleColour <- FALSE
    if (nameZColour == "") 
        nameZColour <- "red"
    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
    }
    cutVector <- colourVector <- NA
    if (!singleColour) {
        dataCategorised <- dF[, nameZColour]
        if (!is.numeric(dataCategorised) && catMethod != "categorical") {
            catMethod = "categorical"
            message(paste("using catMethod='categorical' for non numeric data in", 
                functionName))
        }
        if (length(catMethod) == 1 && catMethod == "categorical") {
            dataCategorised <- as.factor(dataCategorised)
            cutVector <- levels(dataCategorised)
            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) {
                cutVector <- rwmGetClassBreaks(dataCategorised, 
                  catMethod = catMethod, numCats = numCats, verbose = TRUE)
            }
            else if (is.numeric(catMethod) == TRUE) {
                cutVector <- catMethod
            }
            dataCategorised <- cut(dataCategorised, cutVector, 
                include.lowest = TRUE)
            func <- function(x, y) c(paste(x, "-", y[1 + 
                which(y == x)], sep = ""))
            tmp <- sapply(cutVector, cutVector, FUN = func)
            cutVector <- tmp[1:length(tmp) - 1]
        }
        colNameRaw <- nameZColour
        colNameCat <- paste(colNameRaw, "categorised", 
            sep = "")
        dF[[colNameCat]] <- dataCategorised
        numColours <- length(levels(dataCategorised))
        colourVector <- rwmGetColours(colourPalette, numColours)
        dataCatNums <- as.numeric(dataCategorised)
    }
    if (singleColour) 
        col = nameZColour
    else col = colourVector[dataCatNums]
    if (is.na(maxZVal)) 
        maxZVal <- max(dF[, nameZSize], na.rm = TRUE)
    fMult = symbolSize * 4/sqrt(maxZVal)
    cex = fMult * sqrt(dF[, nameZSize])
    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) {
            legendSymbolSizes <- fMult * sqrt(legendVals)
        }
        else {
            sigFigs <- 3
            maxVal <- max(dF[, nameZSize], na.rm = TRUE)
            minVal <- min(dF[, nameZSize], na.rm = TRUE)
            legendVals <- c(signif(minVal, sigFigs), signif(minVal + 
                0.5 * (maxVal - minVal), sigFigs), signif(maxVal, 
                sigFigs))
            legendSymbolSizes <- fMult * sqrt(legendVals)
        }
        legendSymbolChars = c(pch, pch, pch)
        colour4LegendPoints <- "black"
        if (plotZeroVals && legendSymbolSizes[1] == 0) {
            legendSymbolSizes[1] <- 1
            legendSymbolChars[1] <- 3
        }
        x.intersp = symbolSize * 1.3
        y.intersp = symbolSize * 1.3
        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

ggCropMap <- function(myCrop = "Lentils", 
                      myMeasure = "Production", 
                      myYear = 2019, 
                      myFill = "darkgreen", myColor = "darkgreen",
                      myFilename = "crops_world_maps_lentils.png") {
  # Prep data
  xx <- agData_FAO_Crops %>%
    filter(Item == myCrop, 
           Year == myYear,
           Measurement == myMeasure,
           Area %in% agData_FAO_Country_Table$Country) %>%
    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")

© Derek Michael Wright