R/otherplots.R

In OpenLand: Quantitative Analysis and Visualization of LUCC

utils::globalVariables(c("From", "To", "target", "km2", "Year",
                         "QtPixel", "yearFrom", "yearTo", "name",
                         "colorFrom", "colorTo", "lulc", "area",
                         "Category", "Years", "flow_id",
                         "geom_flow", "geom_stratum", "area_gross"))
#' @include plotMethods.R
NULL

#' Area of LUC categories at time points
#'
#'
#' A grouped barplot representing the areas of LUC categories at each time point
#' of the analysed period.
#'
#' @param dataset A table of the multi step transitions (\code{lulc_Multistep})
#' generated by \code{\link{contingencyTable}}.
#' @param legendtable A table containing the LUC legend items and their respective
#' color (\code{tb_legend}).
#' @param title character. The title of the plot.
#' @param caption character. The caption of the plot.
#' @param xlab character. Label for the x axis.
#' @param ylab character. Label for the y axis.
#' @param area_km2 logical. If TRUE the change is computed in km2, if FALSE in
#' pixel counts.
#' @param \dots additional themes parameters, see \code{\link[ggplot2]{theme}}.
#'
#'
#' @seealso \code{ggplot2::\link[ggplot2]{theme}}
#'
#' @return a barplot
#' @export
#'
#' @importFrom graphics par legend text
#'
#' @examples
#'
#' # editing the category names
#'
#' SL_2002_2014$tb_legend$categoryName <- factor(c("Ap", "FF", "SA", "SG", "aa", "SF",
#'                                              "Agua", "Iu", "Ac", "R", "Im"),
#'                                   levels = c("FF", "SF", "SA", "SG", "aa", "Ap",
#'                                              "Ac", "Im", "Iu", "Agua", "R"))
#'
#  # add the color by the same order of the legend factor
#' SL_2002_2014$tb_legend$color <- c("#FFE4B5", "#228B22", "#00FF00", "#CAFF70",
#'                                   "#EE6363", "#00CD00", "#436EEE", "#FFAEB9",
#'                                   "#FFA54F", "#68228B", "#636363")
#' # the plot
#' barplotLand(dataset = SL_2002_2014$lulc_Multistep,
#'             legendtable = SL_2002_2014$tb_legend,
#'             area_km2 = TRUE)
#'
#'
barplotLand <-
  function(dataset,
           legendtable,
           title = NULL,
           caption = "LUC Categories",
           xlab = "Year",
           ylab = "Area (km2 or pixel)",
           area_km2 = TRUE, ...) {


    datachange <- dataset %>%
      left_join(legendtable, by = c("From" = "categoryValue")) %>%
      left_join(legendtable, by = c("To" = "categoryValue")) %>%
      dplyr::select(-c(From, To)) %>%
      rename(
        "From" = "categoryName.x",
        "To" = "categoryName.y",
        "colorFrom" = "color.x",
        "colorTo" = "color.y"
      )

    areaif <- ifelse(isTRUE(area_km2), "km2", "QtPixel")

    datanual <-
      datachange %>% group_by(yearTo, To) %>%
      summarise(area = sum(!!as.name(areaif))) %>%
      rename("Year" = "yearTo", "lulc" = "To") %>% rbind(
        datachange[datachange$yearFrom == first(datachange$yearFrom),] %>%
          group_by(yearFrom, From) %>% # capturing the first year change
          summarise(area = sum(!!as.name(areaif))) %>%
          rename("Year" = "yearFrom", "lulc" = "From"))

    ggplot(data = datanual, aes(as.character(Year), area)) +
      geom_bar(aes(fill = lulc), stat = "identity", position = "dodge") +
      scale_fill_manual(values = legendtable$color[order(legendtable$categoryName)]) +
      labs(fill = caption) +
      xlab(xlab) +
      ylab(ylab) +
      ggtitle(title) +
      theme(plot.title = element_text(hjust = .5),
            ...)

  }




#' One step transitions (Chord diagram)
#'
#'
#' A circlize plot representing the one step transitions between two times point
#' of interest.
#'
#' @param dataset A table of the one step transition (\code{lulc_OneStep}) generated
#' by \code{\link{contingencyTable}}.
#' @param legendtable A table containing the LUC legend items and their respective
#' color (\code{tb_legend}).
#' @param legposition numeric. A vector containing the `x` and `y` values for the
#' position of the legend. (see \code{\link[graphics]{legend}}).
#' @param legtitle character. The title of the legend.
#' @param sectorcol character. The color of the external sector containing the years
#' of compared time points.
#' @param area_km2 logical. If TRUE the change is computed in km2, if FALSE in
#' pixel counts.
#' @param legendsize numeric. Font size of the legend. (see "cex" in \code{\link[graphics]{legend}}).
#' @param y.intersp numeric. character interspacing factor for vertical (y)
#' spacing in the legend.
#' @param x.margin numeric vector ensuring additional space (blank area) on the
#' left or right of the circle for the legend, by default it is c(-1, 1). (see
#' "canvas.xlim" in \code{\link[circlize]{circos.par}})
#'
#' @return A Chord Diagram
#' @export
#'
#' @examples
#'
#' # editing the category names
#'
#' SL_2002_2014$tb_legend$categoryName <- factor(c("Ap", "FF", "SA", "SG", "aa", "SF",
#'                                                "Agua", "Iu", "Ac", "R", "Im"),
#'                                      levels = c("FF", "SF", "SA", "SG", "aa", "Ap",
#'                                               "Ac", "Im", "Iu", "Agua", "R"))
#'
#  # add the color by the same order of the legend factor
#' SL_2002_2014$tb_legend$color <- c("#FFE4B5", "#228B22", "#00FF00", "#CAFF70",
#'                                   "#EE6363", "#00CD00", "#436EEE", "#FFAEB9",
#'                                   "#FFA54F", "#68228B", "#636363")
#'
#' # the plot
#' chordDiagramLand(dataset = SL_2002_2014$lulc_Onestep,
#'                  legendtable = SL_2002_2014$tb_legend)
#'
chordDiagramLand <-
  function(dataset,
           legendtable,
           legposition = c(x = -1.3, y = 0),
           legtitle = "Categories",
           sectorcol = "gray80",
           area_km2 = TRUE,
           legendsize = 1,
           y.intersp = 1,
           x.margin = c(-1, 1)) {


    circle_data <- dataset %>%
      left_join(legendtable, by = c("From" = "categoryValue")) %>%
      left_join(legendtable, by = c("To" = "categoryValue")) %>%
      dplyr::select(-c(From, To)) %>%
      rename(
        "From" = "categoryName.x",
        "To" = "categoryName.y",
        "colorFrom" = "color.x",
        "colorTo" = "color.y"
      ) %>% tidyr::unite("source",
                         c("From", "yearFrom"),
                         sep = "-",
                         remove = FALSE) %>%
      tidyr::unite("target",
                   c("To", "yearTo"),
                   sep = "-",
                   remove = FALSE) %>%
      dplyr::select(source,
                    target,
                    From,
                    To,
                    km2,
                    QtPixel,
                    yearFrom,
                    yearTo,
                    colorFrom,
                    colorTo)

    # input for the circlize function
    onestepcircle <-
      circle_data[order(circle_data$From), ][, c("source", "target", "km2", "QtPixel")]

    # seting the grid.color parameter automatic
    grid_a <- unique(circle_data$colorFrom[order(circle_data$From)])
    names(grid_a) <-
      unique(circle_data$source[order(circle_data$From)])

    grid_b <- unique(circle_data$colorTo[order(circle_data$To)])
    names(grid_b) <- unique(circle_data$target[order(circle_data$To)])

    grid.col <- c(grid_a, grid_b)


    # first and last year
    ano01 <- unique(onestepcircle$source)
    ano02 <- unique(onestepcircle$target)

    # km2 or pixel
    if (isTRUE(area_km2)) {
      onestepcircle <- onestepcircle[c(1,2,3)]} else {
        onestepcircle <- onestepcircle[c(1,2,4)]
      }

    old.par <- graphics::par(no.readonly = TRUE)
    on.exit(graphics::par(old.par))
    circlize::circos.clear()

    # parameters
    circlize::circos.par(
      start.degree = 0,
      gap.degree = 1,
      track.margin = c(-0.01, 0.015),
      points.overflow.warning = TRUE,
      "canvas.xlim" = c(x.margin[[1]], x.margin[[2]])
      )

    graphics::par(mar = rep(0, 4)) # outer part

    # the base plot
    circlize::chordDiagram(
      x = onestepcircle,
      grid.col = grid.col,
      transparency = 0.25,
      directional = 1,
      direction.type = c("arrows", "diffHeight"),
      diffHeight  = -0.02,
      annotationTrack = c("name", "grid")[2],
      annotationTrackHeight = c(0.05, 0.1),
      link.arr.type = "big.arrow",
      link.sort = TRUE,
      link.decreasing = FALSE,
      link.largest.ontop = TRUE,
      preAllocateTracks = list(
        track.height = circlize::uh(5, "mm"),
        track.margin = c(circlize::uh(4, "mm"), circlize::uh(0, "mm"))
      )
    )

    # the km2 label
    for (si in circlize::get.all.sector.index()) {
      circlize::circos.axis(
        h = "top",
        labels.cex = .6,
        sector.index = si,
        track.index = 2
      )
    }

    # adding the externs arcs
    circlize::highlight.sector(
      ano01,
      track.index = 1,
      col = sectorcol,
      text = circle_data$yearFrom[1],
      cex = 0.9,
      text.col = "black",
      niceFacing = TRUE
    )
    circlize::highlight.sector(
      ano02,
      track.index = 1,
      col = sectorcol,
      text = circle_data$yearTo[1],
      cex = 0.9,
      text.col = "black",
      niceFacing = TRUE
    )

    # the legend
    graphics::legend(
      x = legposition[[1]],
      y = legposition[[2]],
      legend = levels(circle_data$From),
      pt.cex = 0,
      cex = legendsize,
      bty = 'n',
      y.intersp = y.intersp,
      fill = legendtable$color[order(legendtable$categoryName)]
    )
    # the title
    graphics::text(
      x = legposition[[1]],
      y = legposition[[2]] + 0.01,
      labels = legtitle,
      pos = 4,
      adj = c(0, 1),
      font = 2,
      cex = legendsize + (legendsize * 0.3)
    )


    circlize::circos.clear()
  }




#' Net and gross changes of LUC categories
#'
#'
#' A stacked barplot showing net and gross changes of LUC categories during the
#' entire analysed time period.
#'
#'
#' @param dataset A table of the multi step transition (\code{lulc_Mulstistep})
#' generated by \code{\link{contingencyTable}}.
#' @param legendtable A table containing the LUC legend items and their respective
#' color (\code{tb_legend}).
#' @param title character. The title of the plot (optional), use \code{NULL} for
#' no title.
#' @param xlab character. Label for the x axis.
#' @param ylab character. Label for the y axis.
#' @param legend_title character. The title of the legend.
#' @param changesLabel character. Labels for the three types of changes, defaults
#' are c(GC = "Gross change", NG = "Net gain", NL = "Net loss").
#' @param color character. A vector defining the three bar colors.
#' @param area_km2  logical. If TRUE the change is computed in km2, if FALSE in
#' pixel counts.
#'
#'
#' @return A bar plot
#' @export
#'
#' @examples
#'
#' # editing the category names
#'
#' SL_2002_2014$tb_legend$categoryName <- factor(c("Ap", "FF", "SA", "SG", "aa", "SF",
#'                                              "Agua", "Iu", "Ac", "R", "Im"),
#'                                      levels = c("FF", "SF", "SA", "SG", "aa", "Ap",
#'                                               "Ac", "Im", "Iu", "Agua", "R"))
#'
#' # the plot
#' netgrossplot(dataset = SL_2002_2014$lulc_Multistep,
#'              legendtable = SL_2002_2014$tb_legend,
#'              title = NULL,
#'              xlab = "LUC Category",
#'              changes = c(GC = "Gross changes", NG = "Net Gain", NL = "Net Loss"),
#'              color = c(GC = "gray70", NG = "#006400", NL = "#EE2C2C"))
#'
#'
netgrossplot <-
  function(dataset,
           legendtable,
           title = NULL,
           xlab = "LUC category",
           ylab = "Area (Km2)",
           legend_title = "Changes",
           changesLabel = c(GC = "Gross change", NG = "Net gain", NL = "Net loss"),
           color = c(GC = "gray70", NG = "#006400", NL = "#EE2C2C"),
           area_km2 = TRUE) {

    datachange <- (dataset %>%
      left_join(legendtable, by = c("From" = "categoryValue")) %>%
      left_join(legendtable, by = c("To" = "categoryValue")) %>%
      dplyr::select(-c(From, To)) %>%
      rename(
        "From" = "categoryName.x",
        "To" = "categoryName.y"))[c(1, 2, 3, 7, 9)]

    areaif <- ifelse(isTRUE(area_km2), "km2", "QtPixel")


    lulc_gain <- datachange %>% dplyr::filter(From != To)

    lulc_loss <- lulc_gain %>% rename("To" = "From", "From" = "To") %>%
      mutate(km2 = -1 * km2, QtPixel = -1 * QtPixel)


    lulc_gainloss_gross <- rbind(lulc_gain, lulc_loss) %>%
      mutate(changes = ifelse(QtPixel > 0, "Gain", "Loss"))


    lulc_gainLoss_net <-
      lulc_gainloss_gross %>% group_by(To) %>% summarise(area = sum(!!as.name(areaif))) %>%
      mutate(changes = ifelse(area > 0, changesLabel[[2]], changesLabel[[3]]))

    if (isTRUE(area_km2)) {
      lulc_gainloss_gross <- lulc_gainloss_gross[c(1, 2, 4, 5, 6)]
    } else {
      lulc_gainloss_gross <- lulc_gainloss_gross[c(1, 3, 4, 5, 6)]
    }

    names(lulc_gainloss_gross) <- c("Period", "area_gross", "From", "To", "changes")
    names(color) <- unname(changesLabel[c("GC", "NG", "NL")]) # pairing the legend with the color


    ggplot(data = lulc_gainloss_gross, aes(To, area_gross)) +
      geom_bar(stat = "identity", width = 0.5, aes(fill = changesLabel[[1]])) +
      geom_bar(
        aes(x = To, y = area, fill = changes),
        data = lulc_gainLoss_net,
        stat = "identity",
        width = 0.4,
        inherit.aes = FALSE
      ) +
      geom_segment(data = lulc_gainLoss_net,
                   aes(
                     x = as.numeric(To) - 0.3,
                     y = area,
                     xend = as.numeric(To) + 0.3,
                     yend = area
                   )) +
      scale_fill_manual(values = color) +
      labs(fill = legend_title) +
      geom_hline(yintercept = 0, size = .3) +
      xlab(xlab) +
      ylab(ylab) +
      ggtitle(title) +
      theme(plot.title = element_text(hjust = .5))
  }



#' Sankey diagram of LUC transitions (one or multistep)
#'
#' A sankey showing the one or multi step LUC transitions during the analysed period.
#'
#' @param dataset A table of the multi step (\code{lulc_Mulstistep}).
#' or one step transitions (\code{lulc_OneStep}) generated by \code{\link{contingencyTable}}.
#' @param legendtable A table containing the LUC legend items and their respective
#' color (\code{tb_legend}).
#' @param iterations numeric. Number of iterations in the diagram layout for
#' computation of the depth (y-position) of each node. See \code{\link[networkD3]{sankeyNetwork}}.
#'
#' @seealso \code{\link[networkD3]{sankeyNetwork}}
#'
#'
#' @return A sankey diagram
#' @export
#'
#' @examples
#'
#' # editing the category names
#'
#' SL_2002_2014$tb_legend$categoryName <- factor(c("Ap", "FF", "SA", "SG", "aa", "SF",
#'                                              "Agua", "Iu", "Ac", "R", "Im"),
#'                                      levels = c("FF", "SF", "SA", "SG", "aa", "Ap",
#'                                               "Ac", "Im", "Iu", "Agua", "R"))
#'
#  # add the color by the same order of the legend factor
#' SL_2002_2014$tb_legend$color <- c("#FFE4B5", "#228B22", "#00FF00", "#CAFF70",
#'                                   "#EE6363", "#00CD00", "#436EEE", "#FFAEB9",
#'                                   "#FFA54F", "#68228B", "#636363")
#'
#' # onestep sankey
#' sankeyLand(dataset = SL_2002_2014$lulc_Onestep,
#'            legendtable = SL_2002_2014$tb_legend)
#'
#' # multistep sankey
#' sankeyLand(dataset = SL_2002_2014$lulc_Multistep,
#'            legendtable = SL_2002_2014$tb_legend)
#'
#'
sankeyLand <- function(dataset, legendtable, iterations = 0) {
  linkMultistep <- dataset %>%
    left_join(legendtable, by = c("From" = "categoryValue")) %>%
    left_join(legendtable, by = c("To" = "categoryValue")) %>%
    dplyr::select(-c(From, To)) %>%
    rename(
      "From" = "categoryName.x",
      "To" = "categoryName.y",
      "colorFrom" = "color.x",
      "colorTo" = "color.y"
    ) %>% tidyr::unite("source",
                c("From", "yearFrom"),
                sep = "-",
                remove = FALSE) %>%
    tidyr::unite("target",
          c("To", "yearTo"),
          sep = "-",
          remove = FALSE) %>%
    dplyr::select(source, target, From, To, km2, yearFrom, yearTo)
  # defining the color scale
  domain <- paste(paste0("'",
                         as.character(levels(legendtable$categoryName)), "'"),
                  collapse = ", ")

  range <- paste(paste0("'",
                        as.character(legendtable$color[order(legendtable$categoryName)]), "'"),
                 collapse = ", ")

  colorScale <-
    paste0(
      "d3.scaleOrdinal().domain([",
      domain,
      "]).range([",
      range,
      "]).unknown(['grey']);"
    )


  nodeMultistep <-
    data.frame(name = c(
      as.character(linkMultistep[order(linkMultistep$From), ]$source),
      as.character(linkMultistep[order(linkMultistep$To), ]$target)
    ) %>% unique()) %>%
    tidyr::separate(name, c("name02", "year"), sep = "-", remove = FALSE)

  linkMultistep$IDsource <-
    match(linkMultistep$source, nodeMultistep$name) - 1
  linkMultistep$IDtarget <-
    match(linkMultistep$target, nodeMultistep$name) - 1

  # Plot
  networkD3::sankeyNetwork(
    Links = as.data.frame(linkMultistep),
    Nodes = nodeMultistep,
    Source = "IDsource",
    Target = "IDtarget",
    colourScale = colorScale,
    Value = "km2",
    NodeID = "name02",
    fontSize = 13,
    nodeWidth = 20,
    fontFamily = "sans-serif",
    iterations = iterations,
    nodePadding = 20,
    sinksRight = FALSE
  )
}