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, linewidth = .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 = unique(c(
        as.character(linkMultistep[order(linkMultistep$From), ]$source),
        as.character(linkMultistep[order(linkMultistep$To), ]$target)
      ))
    ) %>%
    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
  )
}