R/sits_plot.R

In e-sensing/sits.data: Satellite Image Time Series Data Handling

#' @title  Generic interface for ploting time series
#' @method plot sits
#' @name plot
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
#' @description Given a sits tibble with a set of time series, plot them.
#'
#' The plot function produces different plots based on the input data:
#' \itemize{
#'  \item{"all years": }{Plot all samples from the same location together}
#'  \item{"together": }{Plot all samples of the same band and label together}
#' }
#' The plot.sits function makes an educated guess of what plot is required,
#' based on the input data. If the input data has less than 30 samples, it
#' will default to "all years". If there are more than 30 samples,
#' it will default to "together".
#'
#' @param  x            object of class "sits"
#' @param  y            ignored
#' @param ...           further specifications for \link{plot}.
#' @param  colors       Color pallete to be used (based on Color Brewer
#'                      - default is "Dark2").
#' @return Input sits tibble (useful for chaining functions).
#'
#' @examples
#' \donttest{
#' # Read a set of samples with 2 classes ("Cerrado" and "Pasture")
#' # Plot all the samples together
#' plot(cerrado_2classes)
#' # Plot the first 20 samples (defaults to "allyears")
#' plot(cerrado_2classes[1:20,])
#' }
#' @export
plot.sits <- function(x, y, ..., colors = "Dark2") {

    stopifnot(missing(y))

    # Are there more than 30 samples? Plot them together!
    if (nrow(x) > 30)
        .sits_plot_together(x, colors)
    # If no conditions are met, take "allyears" as the default
    else
        .sits_plot_allyears(x, colors)
    # return the original sits tibble - useful for chaining
    return(invisible(x))
}

#' @title  Generic interface for ploting patterns
#' @name   plot.patterns
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
#' @description Given a sits tibble with a set of patterns, plot them.
#'
#' @param  x             object of class "patterns"
#' @param  y             ignored
#' @param  ...           further specifications for \link{plot}.
#' @return Input sits tibble (useful for chaining functions).
#'
#' @examples
#' \donttest{
#' # Read a set of samples with 2 classes ("Cerrado" and "Pasture")
#' # Plot the patterns
#' plot(sits_patterns(cerrado_2classes))
#' }
#' @export
plot.patterns <- function(x, y, ...) {
    stopifnot(missing(y))
    .sits_plot_patterns(x)

}
#' @title  Generic interface for plotting a SOM map
#' @name   plot.som_map
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
#' @description plots a SOM map generated by "sits_som_map"
#' The plot function produces different plots based on the input data:
#' \itemize{
#'  \item{"codes": }{Plot the vector weight for in each neuron.}
#'  \item{"mapping": }{Shows where samples are mapped.}
#' }
#'
#' @param  x          Object of class "som_map"
#' @param  y          Ignored
#' @param  ...        Further specifications for \link{plot}.
#' @param  type       Type of plot: "codes" for neuron weight (time series) and
#'                    "mapping" for the number of samples allocated in a neuron.
#' @param  whatmap    What data layer will be plotted.
#'
#' @examples
#' \donttest{
#' # Produce a cluster map
#' som_cluster <- sits_som_map(prodes_226_064)
#' # Plot the clusters
#' plot(som_cluster, type = "codes")
#' # Plot kohonen map showing where the samples were allocated
#' plot(som_cluster, type = "mapping")
#' }
#' @export
plot.som_map <- function(x, y, ..., type = "codes", whatmap = 1) {
    stopifnot(missing(y))
    .sits_plot_som_map(x, type, whatmap)
}

#' @title Plot all intervals of one time series for the same lat/long together
#' @name .sits_plot_allyears
#'
#' @description For each lat/long location in the data, join temporal
#' instances of the same place together for plotting.
#' @param data    One or more time series (stored in a sits tibble).
#' @param colors  The color pallete to be used (default is "Set2").
.sits_plot_allyears <- function(data, colors) {
    locs <- dplyr::distinct(data, longitude, latitude)

    purrr::pmap(list(locs$longitude, locs$latitude), function(long, lat) {
        dplyr::filter(data, longitude == long, latitude == lat) %>%
            .sits_ggplot_series(colors) %>%
            graphics::plot()
    })
}



#' @title Plot classification patterns
#' @name .sits_plot_patterns
#' @author Victor Maus, \email{vwmaus1@@gmail.com}
#' @description   Plots the patterns to be used for classification
#'                (code is reused from the dtwSat package by Victor Maus).
#' @param data    One or more time series containing patterns.
#'
.sits_plot_patterns <- function(data) {
    # prepare a data frame for plotting
    plot.df <- data.frame()

    # put the time series in the data frame
    purrr::pmap(list(data$label, data$time_series),
                function(label, ts) {
                    lb <- as.character(label)
                    # extract the time series and convert
                    df <- data.frame(Time = ts$Index, ts[-1], Pattern = lb)
                    plot.df <<- rbind(plot.df, df)
                })

    plot.df <- reshape2::melt(plot.df, id.vars = c("Time", "Pattern"))

    # Plot temporal patterns
    gp <-  ggplot2::ggplot(plot.df, ggplot2::aes_string(x = "Time",
                                                        y = "value",
                                                        colour = "variable") ) +
        ggplot2::geom_line() +
        ggplot2::facet_wrap(~Pattern) +
        ggplot2::theme(legend.position = "bottom") +
        ggplot2::scale_x_date(labels = scales::date_format("%b")) +
        ggplot2::guides(colour = ggplot2::guide_legend(title = "Bands")) +
        ggplot2::ylab("Value")

    graphics::plot(gp)

    return(invisible(data))
}

#' @title Plot a set of time series for the same spatio-temporal reference
#'
#' @name .sits_plot_together
#'
#' @description Plots all time series for the same label together.
#' This function is useful to find out the spread of the values of
#' the time series for a given label.
#'
#' @param    data    A sits tibble with the list of time series to be plotted.
#' @param    colors  The color pallete to be used (default is "Set1").
#' @return           The input sits tibble (useful for chaining functions).
#'
# create a data frame with the median, and 25% and 75% quantiles
.sits_plot_together <- function(data, colors) {
    create_IQR <- function(DT, band) {
        data.table::setnames(DT, band, "V1")
        DT_med <- DT[,stats::median(V1), by = Index]
        data.table::setnames(DT_med,"V1", "med")
        DT_qt25 <- DT[,stats::quantile(V1, 0.25), by = Index]
        data.table::setnames(DT_qt25,"V1", "qt25")
        DT_qt75 <- DT[,stats::quantile(V1, 0.75), by = Index]
        data.table::setnames(DT_qt75,"V1", "qt75")
        DT_qts <- merge(DT_med, DT_qt25)
        DT_qts <- merge(DT_qts, DT_qt75)
        data.table::setnames(DT, "V1", band)
        return(DT_qts)
    }
    # this function plots the values of all time series together (for one band)
    plot_samples <- function(DT, DT_qts, band, label, number) {
        # melt the data into long format (required for ggplot to work)
        DT_melted <- data.table::melt(DT, id.vars = "Index")
        # make the plot title
        title <- paste("Samples (", number, ") for class ",
                       label, " in band = ", band, sep = "")
        # plot all data together
        g <- .sits_ggplot_together(DT_melted, DT_qts, title)
        graphics::plot(g)
    }

    # how many different labels are there?
    labels <- sits_labels(data)$label

    labels %>%
        purrr::map(function(l) {
            lb <- as.character(l)
            # filter only those rows with the same label
            data2.tb <- dplyr::filter(data, label == lb)
            # how many time series are to be plotted?
            number <- nrow(data2.tb)
            # what are the band names?
            bands  <- sits.data::sits_bands(data2.tb)
            # what are the reference dates?
            ref_dates <- sits.data::sits_time_series_dates(data2.tb)
            # align all time series to the same dates
            data2.tb <- sits.data::sits_align_dates(data2.tb, ref_dates)


            bands %>%
                purrr::map(function(band) {
                    # select the band to be shown
                    band.tb <- sits_select_bands(data2.tb, band)
                    # create a list with all time series for this band
                    DT.lst <- purrr::map(band.tb$time_series,
                                         function(ts) {
                                             data.table::data.table(ts)
                                         })
                    # set "Index" as the key for all data.tables in the list
                    DT.lst <- purrr::map(DT.lst,
                                         function(dt) {
                                             data.table::setkey(dt, Index)
                                         })
                    # rename the columns of the data table prior to merging
                    length_DT <- length(DT.lst)
                    DT.lst <- purrr::map2(DT.lst, 1:length_DT,
                                 function(dt, i) {
                                    data.table::setnames(dt, band,
                                          paste0(band, ".", as.character(i)))
                                          })
                    # merge the list of data.tables into a single table
                    DT <- Reduce(function(...) merge(..., all = T), DT.lst)

                    # create another data.table with all the rows together
                    # (required to compute the median and quartile values)
                    ts <- band.tb$time_series
                    DT_byrows <- data.table::data.table(dplyr::bind_rows(ts))
                    # compute the median and quartile values
                    DT_qts <- create_IQR(DT_byrows, band)
                    # plot the time series together
                    # (highlighting the median and quartiles 25% and 75%)
                    plot_samples(DT, DT_qts, band, lb, number)
                })
        })
}

#' @title Plot one timeSeries using ggplot
#'
#' @name .sits_ggplot_series
#'
#' @description Plots a set of time series using ggplot. This function is used
#' for showing the same lat/long location in a series of time steps.
#'
#' @param row         A row of a sits tibble with the time series to be plotted.
#' @param colors      Brewer colors to be used for plotting.
.sits_ggplot_series <- function(row, colors = "Dark2") {
    # create the plot title
    plot_title <- .sits_plot_title(row$latitude, row$longitude, row$label)
    #extract the time series
    data.ts <- row$time_series
    # melt the data into long format
    melted.ts <- data.ts %>%
        reshape2::melt(id.vars = "Index") %>%
        as.data.frame()
    # plot the data with ggplot
    g <- ggplot2::ggplot(melted.ts, ggplot2::aes(x = Index,
                                                 y = value,
                                                 group = variable)) +
        ggplot2::geom_line(ggplot2::aes(color = variable)) +
        ggplot2::labs(title = plot_title) +
        ggplot2::scale_color_brewer(palette = colors)
    return(g)
}

#' @title Plot many timeSeries together using ggplot
#'
#' @name .sits_ggplot_together
#'
#' @description Plots a set of  time series together.
#'
#' @param melted.tb   A tibble with the time series (already melted).
#' @param means.tb    Means and std deviations of the time series.
#' @param plot_title  The title for the plot.
.sits_ggplot_together <- function(melted.tb, means.tb, plot_title) {
    g <- ggplot2::ggplot(data = melted.tb, ggplot2::aes(x = Index,
                                                        y = value,
                                                        group = variable)) +
        ggplot2::geom_line(colour = "#819BB1", alpha = 0.5) +
        ggplot2::labs(title = plot_title) +
        ggplot2::geom_line(data = means.tb,
                           ggplot2::aes(x = Index, y = med),
                           colour = "#B16240", size = 2, inherit.aes = FALSE) +
        ggplot2::geom_line(data = means.tb,
                           ggplot2::aes(x = Index, y = qt25),
                           colour = "#B19540", size = 1, inherit.aes = FALSE) +
        ggplot2::geom_line(data = means.tb,
                           ggplot2::aes(x = Index, y = qt75),
                           colour = "#B19540", size = 1, inherit.aes = FALSE)
    return(g)
}

#' @title Create a plot title to use with ggplot
#' @name .sits_plot_title
#'
#' @description Creates a plot title from row information.
#'
#' @param latitude   Latitude of the location to be plotted.
#' @param longitude  Longitude of the location to be plotted.
#' @param label      Lable of the location to be plotted.
#' @return A string with the title to be used in the plot.
.sits_plot_title <- function(latitude, longitude, label) {
    title <- paste("location (",
                   latitude,  ", ",
                   longitude, ") - ",
                   label,
                   sep = "")
    return(title)
}

#' @title Plot a dendrogram
#' @name .sits_plot_dendrogram
#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br}
#'
#' @description Plot a dendrogram
#'
#' @param data          A sits tibble with data used to extract the dendrogram.
#' @param dendro        Cluster object produced by `sits_cluster` function.
#' @param cutree_height A dashed horizontal line to be drawn
#'                      indicating the height of dendrogram cutting.
#' @param colors        A color scheme as showed in `sits_color_name` function.
.sits_plot_dendrogram <- function(data,
                                  dendro,
                                  cutree_height = NULL,
                                  colors = "RdYlGn"){
    # ensures that a cluster object  exists
    assertthat::assert_that(!purrr::is_null(dendro),
                   msg = "plot_dendrogram: no valid dendogram object available")

    # get unique labels
    data_labels <- data$label
    u_lb       <- base::unique(data_labels)

    # warns if the number of available colors is insufficient to all labels
    if (length(u_lb) > (
        length(.sits_brewerRGB[[.sits_color_name(colors)]]) - 1))
        message("sits_plot_dendrogram: The number of labels
                is greater than the number of available colors.")

    # extract the dendrogram object
    hclust_cl <- methods::S3Part(dendro, strictS3 = TRUE)
    dendrogram <- hclust_cl %>%
        stats::as.dendrogram()

    # prepare labels color vector
    cols <- character(length(data_labels))
    cols[] <- grDevices::rgb(0/255,   0/255,   0/255,   0/255)

    i <- 1
    seq(u_lb) %>%
        purrr::map(function(i) {
            cols[data_labels[dendro$order] == u_lb[i]] <<-
                .sits_brewerRGB[[.sits_color_name(colors)]][[length(u_lb)]][[i]]
            i <<- i + 1
        })

    # plot the dendrogram
    dendrogram %>%
        dendextend::set("labels", character(length = length(data_labels))) %>%
        dendextend::set("branches_k_color", value = cols,
                        k = length(data_labels)) %>%
        graphics::plot(ylab = paste(tools::file_path_sans_ext(dendro@method),
                                    "linkage distance"))


    # plot cutree line
    if (!purrr::is_null(cutree_height))
        graphics::abline(h = cutree_height, lty = 2)

    # plot legend
    graphics::legend("topright",
        fill = as.character(
                .sits_brewerRGB[[.sits_color_name(colors)]][[length(u_lb)]]),
                legend = u_lb)
}

#' @title  Plot the SOM grid with neurons labeled
#' @name   .sits_plot_som_map
#' @author Lorena Santos \email{lorena.santos@@inpe.br}
#' @description Given a kohonen object with a set of time neurons, plot them.
#'
#' The plot function produces different plots based on the input data:
#' \itemize{
#'  \item{"codes": }{Plot the vector weight for each neuron.}
#'  \item{"mapping": }{Shows where samples are mapped.}
#' }
#' @param  koh        Kohonen map produced by "sits_som_map" function
#' @param  type       Type of plot ("codes" or "mapping")
#' @param  whatmap    What data layer will be plotted.
.sits_plot_som_map <- function(koh, type = "codes", whatmap = 1)
{
    if (type == "mapping") {
        graphics::plot(koh$som_properties,
                       bgcol = koh$som_properties$paint_map ,
                       "mapping", whatmap = whatmap)
    } else{
        graphics::plot(koh$som_properties,
                       bgcol = koh$som_properties$paint_map ,
                       "codes", whatmap = whatmap)
    }

    #create a legend
    leg <- cbind(koh$som_properties$neuron_label, koh$som_properties$paint_map)
    graphics::legend(
        "bottomright",
        legend = unique(leg[, 1]),
        col = unique(leg[, 2]),
        pch = 15,
        pt.cex = 2,
        cex = 1,
        text.col = "black",
        #horiz = T ,
        inset = c(0.0095, 0.05),
        xpd = TRUE,
        ncol = 1
    )
}