R/plot.R

Defines functions .plot_get_change_colors .plot_reshape_long .plot_show_joining_chart .plot_set_ggplot_line_theme .plot_line_get_sec_y_axis .plot_line_set_y_axes .plot_line_edit_data_table .plot_add_coeff_to_sensors_table .plot_get_sensors_table mc_plot_line .plot_print_png .plot_print_raster_pngs .plot_print_pdf .plot_get_file_parts .plot_set_ggplot_raster_theme .plot_set_ggplot_physical_colors .plot_raster_physical .plot_get_data_sensors_by_physical mc_plot_raster mc_plot_image .plot_get_start_month_by_datetime .plot_get_months_from_xlimit .plot_get_values_range .plot_logger_moisture .plot_logger_temperature .plot_get_xlimit .plot_logger_set_parameters .plot_get_logger_sensors_by_physical .plot_logger mc_plot_loggers

Documented in mc_plot_image mc_plot_line mc_plot_loggers mc_plot_raster

.plot_const_MOISTURE_PHYSICAL <- c(.model_const_PHYSICAL_moisture_raw,
                                   .model_const_PHYSICAL_VWC)
.plot_const_MESSAGE_DUPLICATED_SENSOR <- "Sensor {duplicated_sensors} contains multiple physicals. It is not allowed."
.plot_const_FACET_LOCALITY <- "locality"
.plot_const_FACET_PHYSICAL <- "physical"

.plot_const_PALETTE <- c(RColorBrewer::brewer.pal(9, "Set1"),
                         RColorBrewer::brewer.pal(12, "Set3"),
                         RColorBrewer::brewer.pal(8, "Set2"),
                         RColorBrewer::brewer.pal(12, "Paired"),
                         RColorBrewer::brewer.pal(8, "Dark2"),
                         RColorBrewer::brewer.pal(8, "Accent"),
                         RColorBrewer::brewer.pal(9, "Set1"),
                         RColorBrewer::brewer.pal(12, "Set3"),
                         RColorBrewer::brewer.pal(8, "Set2"),
                         RColorBrewer::brewer.pal(12, "Paired"),
                         RColorBrewer::brewer.pal(8, "Dark2"),
                         RColorBrewer::brewer.pal(8, "Accent"))

#' Plot data from loggers
#'
#' Function save separate files (*.png) per the loggers to the directory.
#' Only Raw-format supported, Agg-format not supported.
#' For Agg-format use [myClim::mc_plot_line()]. Function was primary designed
#' for Tomst  TMS loggers for fast, and easy data visualization.
#'
#' @template param_myClim_object_raw
#' @param directory path to output directory
#' @template param_localities
#' @template param_sensors
#' @param crop datetime range for plot, not cropping if NA (default c(NA, NA))
#' @export
#' @return PNG files created in the output directory
#' @examples
#' tmp_dir <- file.path(tempdir(), "plot")
#' mc_plot_loggers(mc_data_example_clean, tmp_dir)
#' unlink(tmp_dir, recursive=TRUE)
mc_plot_loggers <- function(data, directory, localities=NULL, sensors=NULL, crop=c(NA, NA)) {
    oldpar <- par(no.readonly = TRUE)
    on.exit(suppressWarnings(par(oldpar)))
    .common_stop_if_not_raw_format(data)
    data <- mc_filter(data, localities, sensors)
    .prep_check_datetime_step_unprocessed(data)
    loggers <- .common_get_loggers(data)
    dir.create(directory, showWarnings = F)
    for(logger in loggers) {
        i <- 1
        repeat {
            filename <- file.path(directory, stringr::str_glue("{logger$metadata@serial_number}_{i}.png"))
            if(!file.exists(filename)) {
                break
            }
            i <- i + 1
        }
        .plot_logger(logger, filename, crop)
    }
}

.plot_logger <- function(logger, filename, crop=c(NA, NA)) {
    png(filename=filename, width=1920, height=1000, res=200)
    physical <- .plot_get_logger_sensors_by_physical(logger)
    moisture_physical <- intersect(.plot_const_MOISTURE_PHYSICAL, names(physical))
    .plot_logger_set_parameters(physical, moisture_physical)
    xlimit <- .plot_get_xlimit(logger$datetime, crop)
    months <- .plot_get_months_from_xlimit(xlimit)
    .plot_logger_temperature(logger, xlimit, months, physical[[.model_const_PHYSICAL_T_C]])
    if(length(moisture_physical) > 0){
        .plot_logger_moisture(logger, xlimit, months, physical[[moisture_physical[[1]]]])
    }
    axis.POSIXct(1, at=months, labels=TRUE, format="%m/%Y", las=2)
    dev.off()
}

.plot_get_logger_sensors_by_physical <- function(logger) {
    physical <- purrr::map_chr(logger$sensors, function(x) {
        .common_get_sensor_info(x$metadata)@physical})
    sensor_names <- names(logger$sensors)
    tapply(sensor_names, physical, c, simplify = FALSE)
}

.plot_logger_set_parameters <-function(physical_quantities, moisture_sensor)
{
    top_margin <- 1.5
    right_margin <- 8
    left_margin <- 5
    if(length(moisture_sensor) > 0) {
        layout(matrix(1:2))
        bottom_margin <- 0
    }
    else {
        bottom_margin <- 5
    }
    par(mar=c(bottom_margin, left_margin, top_margin, right_margin), mgp=c(2.5,1,0), las=1)
}

.plot_get_xlimit <- function(datetime, crop){
    result <- crop
    if(is.na(result[[1]])) {
        result[[1]] <- min(datetime)
    }
    if(is.na(result[[2]])) {
        result[[2]] <- max(datetime)
    }
    .common_as_utc_posixct(result)
}

.plot_logger_temperature <- function(logger, xlimit, months, sensors)
{
    if(is.null(sensors)) {
        ylimit <- c(-15, 30)
    }
    else {
        sensor_info <- sapply(sensors, function(x) {
            .common_get_sensor_info(logger$sensors[[x]]$metadata)})
        values_range <- .plot_get_values_range(logger, sensors)
        ylimit <- c(min(c(-15, values_range[[1]]), na.rm=T), max(c(30, values_range[[2]]), na.rm=T))
    }
    plot(logger$datetime, rep(NA, length(logger$datetime)), type="n", xaxt="n", xlab=NA, ylab="Temperature (\u00b0C)",
         main=logger$metadata@serial_number, xlim=xlimit, ylim=ylimit)
    abline(v=months, lty=1, col=gray(0.9))
    grid(nx=NA, ny=NULL, col=gray(0.9), lty=1)
    abline(0,0,col="gray70")
    box()
    for(sensor_name in sensors) {
        lines(logger$datetime, logger$sensors[[sensor_name]]$values, col=sensor_info[[sensor_name]]@plot_color,
              lwd=sensor_info[[sensor_name]]@plot_line_width)
    }
    colors <- sapply(sensors, function(x) sensor_info[[x]]@plot_color)
    line_widths <- sapply(sensors, function(x) sensor_info[[x]]@plot_line_width)
    legend(grconvertX(1610, "device"), grconvertY(60, "device"), lwd=line_widths,
           sensors, lty = rep(1, length(sensors)), col=colors, xpd=NA)
}

.plot_logger_moisture <- function(logger, xlimit, months, sensor)
{
    sensor_info <- .common_get_sensor_info(logger$sensors[[sensor]]$metadata)
    physical <- myClim::mc_data_physical[[sensor_info@physical]]
    right_margin <- 8
    par(mar=c(5, 5, 0.25, right_margin))
    par(new=F)
    plot(logger$datetime, logger$sensors[[sensor]]$values, type="n", xaxt="n", yaxt="n", xlab=NA, ylab=NA, xlim=xlimit)
    abline(v=months, lty=1, col=gray(0.9))
    grid(nx=NA, ny=NULL, col=gray(0.9), lty=1)
    box()
    axis(4)
    lines(logger$datetime, logger$sensors[[sensor]]$values, col=sensor_info@plot_color,
          lwd=sensor_info@plot_line_width)
    mtext(physical@description, 4, line=3, las=3)
}

.plot_get_values_range <- function(logger, sensors){
    result <- min(sapply(sensors, function(x) min(logger$sensors[[x]]$values, na.rm = T)), na.rm = T)
    result[[2]] <- max(sapply(sensors, function(x) max(logger$sensors[[x]]$values, na.rm = T)), na.rm = T)
    result
}

.plot_get_months_from_xlimit <- function(xlimit){
    start_month <- .plot_get_start_month_by_datetime(xlimit[[1]])
    end_month <- .plot_get_start_month_by_datetime(xlimit[[2]])
    seq(start_month, end_month, "months")
}

.plot_get_start_month_by_datetime <- function(datetime){
    as.POSIXct(paste0(format(datetime, "%Y-%m"), "-01 00:00", tz="UTC"))
}

#' Plot data - image
#'
#' Function plots single sensor form myClim data into PNG file with image() R base function.
#' This was designed for fast, and easy data visualization especially focusing on missing
#' values visualization and general data picture.
#'
#' @details Be careful with bigger data. Can take some time. 
#' @template param_myClim_object
#' @param filename output file name (file path)
#' @param title of plot; default is empty
#' @template param_localities
#' @template param_sensors
#' @param height of image; default = 1900
#' @param left_margin width of space for sensor_labels; default = 12
#' @template param_use_utc
#' @return PNG file created as specified in output file name
#' @export
#' @examples
#' tmp_dir <- tempdir()
#' tmp_file <- tempfile(tmpdir = tmp_dir)
#' mc_plot_image(mc_data_example_clean, tmp_file, "T1 sensor", sensors="TMS_T1")
#' file.remove(tmp_file)
mc_plot_image <- function(data, filename, title="", localities=NULL, sensors=NULL,
                          height=1900, left_margin=12, use_utc=TRUE) {
    oldpar <- par(no.readonly = TRUE)
    on.exit(suppressWarnings(par(oldpar)))
    data_table <- mc_reshape_wide(data, localities, sensors, use_utc=use_utc)
    values_matrix <- as.matrix(data_table[,-1])
    png(filename=filename,width=1900, height=height, res=200)
    x_labels <- substr(data_table$datetime[seq(1, nrow(data_table), len=20)], 1, 10)
    bottom_margin <- 7
    top_margin <- 3
    right_margin <- 8
    par(mar=c(bottom_margin, left_margin, top_margin, right_margin))
    image(values_matrix, xaxt ="n", yaxt="n", col = hcl.colors(12, "viridis", rev = FALSE))
    axis(side = 1, at=seq(0, 1, len=20), labels=x_labels, las=3)
    cex.axis_function <- function() {
        ref_value <- 50
        current_value <- height / (ncol(data_table) - 1)
        if(current_value >= ref_value) return(1)
        current_value / ref_value
    }
    axis(side = 2, at=seq(0, 1, len=ncol(values_matrix)), labels=colnames(data_table)[-1], las=2, cex.axis=cex.axis_function())
    legend_values <- round(seq(max(values_matrix, na.rm=T), min(values_matrix, na.rm=T), len=12), 2)
    legend(grconvertX(1630, "device"), grconvertY(120, "device"),
           legend_values, fill = hcl.colors(12, "viridis", rev = TRUE), xpd = NA)
    title(main=title, line=0.5, cex.lab=1.2)
    dev.off()
}

#' Plot data - ggplot2 geom_raster
#'
#' Function plots data with ggplot2 geom_raster. Plot is returned as ggplot faced raster and
#' is primary designed to be saved as .pdf file (recommended) or .png file.
#' Plotting into R environment without saving any file is also possible.
#' See details.
#'
#' @details Saving as the .pdf file is recommended, because the plot is optimized
#' to be paginate PDF (facet raster plot is distributed to pages), which is especially useful
#' for bigger data. In case of plotting multiple sensors to PDF, the facet grids are grouped by sensor.
#' I.e., all localities of sensor_1 followed by all localities of sensor_2 etc.
#' When plotting only few localities, but multiple sensors,
#' each sensor has own page. I.e., when plotting data from one locality, and 3 sensors resulting PDF has 3 pages.
#' In case of plotting PNG, sensors are plotted in separated images (PNG files) by physical.
#' I.e, when plotting 3 sensors in PNG it will save 3 PNG files named after sensors.
#' Be careful with bigger data in PNG. Play with `png_height` and `png_width`.
#' When too small height/width, image does not fit and is plotted incorrectly. Plotting into
#' R environment instead of saving PDF or PNG is possible, but is recommended only for
#' low number  of localities (e.g. up to 10), because
#' high number of localities plotted in R environment results in very small picture which is hard/impossible to read.
#'
#' 
#' @template param_myClim_object
#' @param filename output with the extension - supported formats are .pdf and .png (default NULL)
#' If NULL then the plot is shown/returned into R environment as ggplot object, but not saved to file.
#' @param sensors names of sensor; should have same physical unit see `names(mc_data_sensors)`
#' @param by_hour if TRUE, then y axis is plotted as an hour, else original time step (default TRUE) 
#' @param png_width width for png output (default 1900)
#' @param png_height height for png output (default 1900)
#' @param viridis_color_map viridis color map option; if NULL, then used value from mc_data_physical
#'
#' * "A" - magma
#' * "B" - inferno
#' * "C" - plasma
#' * "D" - viridis
#' * "E" - cividis
#' * "F" - rocket
#' * "G" - mako
#' * "H" - turbo
#' @param start_crop POSIXct datetime in UTC for crop data (default NULL)
#' @param end_crop POSIXct datetime in UTC for crop data (default NULL)
#' @template param_use_utc
#' @return list of ggplot2 objects
#' @examples
#' tmp_dir <- tempdir()
#' tmp_file <- tempfile(tmpdir = tmp_dir, fileext=".pdf")
#' mc_plot_raster(mc_data_example_agg, filename=tmp_file, sensors=c("TMS_T3","TM_T"))
#' file.remove(tmp_file)
#' @export
mc_plot_raster <- function(data, filename=NULL, sensors=NULL, by_hour=TRUE, png_width=1900, png_height=1900,
                           viridis_color_map=NULL, start_crop=NULL, end_crop=NULL, use_utc=TRUE) {
    data <- mc_filter(data, sensors=sensors)
    if(!is.null(start_crop) || !is.null(end_crop)) {
        data <- mc_prep_crop(data, start_crop, end_crop)
    }
    sensors_table <- .plot_get_data_sensors_by_physical(data)
    sensors_table <- dplyr::group_by(sensors_table, .data$physical)

    group_function <- function(group, .y) {
        filtered_data <- mc_filter(data, sensors=group$sensor)
        .plot_raster_physical(filtered_data, by_hour, viridis_color_map, use_utc)
    }

    plots <- dplyr::group_map(sensors_table, group_function)

    if(!is.null(filename)) {
        file_parts <- .plot_get_file_parts(filename)
        if(file_parts[[2]] == "pdf"){
            .plot_print_pdf(filename, plots, locality_id ~ sensor_name, 40, TRUE)
        } else if(file_parts[[2]] == "png") {
            .plot_print_raster_pngs(file_parts[[1]], plots, dplyr::group_keys(sensors_table)$physical, png_width, png_height)
        } else {
            stop(stringr::str_glue("Format of {filename} isn't supported."))
        }
    }
    plots <- purrr::map(plots, ~ .x + ggplot2::facet_grid(locality_id ~ sensor_name))
    return(plots)
}

.plot_get_data_sensors_by_physical <- function(data) {
    item_function <- function (item) {
        physical <- purrr::map_chr(item$sensors, function(x) {
            .common_get_sensor_info(x$metadata)@physical})
        tibble::tibble(sensor=names(physical),
                       physical=unname(physical))
    }

    raw_locality_function <- function(locality) {
        purrr::map_dfr(locality$loggers, item_function)
    }

    if(.common_is_agg_format(data)) {
        result <- purrr::map_dfr(data$localities, item_function)
    } else {
        result <- purrr::map_dfr(data$localities, raw_locality_function)
    }
    result <- dplyr::distinct(result)
    if(any(duplicated(result$sensor))) {
        duplicated_sensors <- result$sensor[duplicated(result$sensor)]
        stop(stringr::str_glue(.plot_const_MESSAGE_DUPLICATED_SENSOR))
    }
    return(result)
}

.plot_raster_physical <- function(data, by_hour, viridis_color_map, use_utc) {
    data_table <- mc_reshape_long(data, use_utc=use_utc)
    data_table <- dplyr::mutate(data_table, date = lubridate::date(.data$datetime))
    data_table$value <- as.numeric(data_table$value)
    if(by_hour) {
        data_table <- dplyr::mutate(data_table, y_values = lubridate::hour(.data$datetime))
        y_name <- "hour"
    } else {
        data_table <- dplyr::mutate(data_table, y_values = format(.data$datetime, format = "%H:%M:%S"))
        y_name <- "time"
    }
    plot <- ggplot2::ggplot(data_table, ggplot2::aes(.data$date, .data$y_values, na.rm = FALSE))
    plot <- plot + ggplot2::ylab(y_name)
    plot <- plot + ggplot2::geom_raster(ggplot2::aes(fill=.data$value))
    plot <- .plot_set_ggplot_physical_colors(data, plot, viridis_color_map)
    plot <- plot + .plot_set_ggplot_raster_theme()
    plot <- plot + ggplot2::scale_x_date(date_labels="%Y-%m")
}

.plot_set_ggplot_physical_colors <- function(data, plot, viridis_color_map) {
    locality <- dplyr::first(data$localities)
    if(.common_is_agg_format(data)) {
        item <- locality
    } else {
        item <- dplyr::first(locality$loggers)
    }
    sensor_metadata <- dplyr::first(item$sensors)$metadata
    if(is.na(sensor_metadata@sensor_id) || !(sensor_metadata@sensor_id %in% names(myClim::mc_data_sensors)) ||
        is.na(myClim::mc_data_sensors[[sensor_metadata@sensor_id]]@physical)) {
        if(is.null(viridis_color_map)) {
            viridis_color_map <- "D"
        }
        return(plot + viridis::scale_fill_viridis(name=sensor_metadata@name, option=viridis_color_map, direction=1))
    }

    sensor <- myClim::mc_data_sensors[[sensor_metadata@sensor_id]]
    physical <- myClim::mc_data_physical[[sensor@physical]]
    if(is.null(viridis_color_map)) {
        viridis_color_map <- physical@viridis_color_map
    }
    plot + viridis::scale_fill_viridis(name=physical@description, option=viridis_color_map, direction=1)
}

.plot_set_ggplot_raster_theme <- function() {
    ggplot2::theme(strip.text.y = ggplot2::element_text(angle = 0),
                   axis.ticks.y=ggplot2::element_blank(),
                   axis.text.y = ggplot2::element_blank(),
                   legend.position="bottom",
                   legend.key.width= ggplot2::unit(2, 'cm'),
                   legend.key.height= ggplot2::unit(0.4, 'cm'),
                   panel.border = ggplot2::element_blank(),
                   panel.grid.major = ggplot2::element_blank(),
                   panel.grid.minor = ggplot2::element_blank())
}

.plot_get_file_parts <- function(filename) {
    match <- stringr::str_match(filename, "(.+)\\.([^.]+)$")
    match[2:3]
}

.plot_print_pdf <- function(filename, plots, facets, nrow, do_facet, scales="fixed") {
    facet_function <- function(page, drop) {
        ggforce::facet_grid_paginate(facets, ncol=1, nrow=nrow, page=page, drop=drop, byrow=FALSE, scales=scales)
    }
    if(do_facet) {
        plots <- purrr::map(plots, ~ .x + facet_function(1, FALSE))
    }

    print_plot <- function(plot) {
        if(do_facet) {
            n_pages <- sum(ggforce::n_pages(plot))
            purrr::walk(seq(1:n_pages), function (x) print(plot + facet_function(x, TRUE)))
        } else {
            print(plot)
        }
    }

    pdf(filename, family="ArialMT", paper="a4", width=210/25.4, height=297/25.4)
    purrr::walk(plots, print_plot)
    dev.off()
}

.plot_print_raster_pngs <- function(filename_prefix, plots, physicals, width, height) {
    print_function <- function(plot, physical) {
        filename <- stringr::str_glue("{filename_prefix}_{physical}.png")
        .plot_print_png(filename, plot, width, height, locality_id ~ sensor_name, TRUE)
    }
    purrr::walk2(plots, physicals, print_function)
}

.plot_print_png <- function(filename, plot, width, height, facets, do_facet, scales="fixed") {
    if(do_facet){
        plot <- plot + ggforce::facet_grid_paginate(facets, ncol = 1, byrow = FALSE, scales=scales)
    }
    png(filename, width=width, height=height, res=200)
    print(plot)
    dev.off()
}

#' Plot data - ggplot2 geom_line
#'
#' Function plots data with ggplot2 geom_line. Plot is returned as ggplot faced grid and
#' is optimized for saving as facet, paginated PDF file.
#'
#' @details
#' Saving as the PDF file is recommended, because the plot is optimized
#' to be paginate PDF (facet line plot is distributed to pages), each locality can be 
#' represented by separate plot (`facet = "locality"`) default, which is especially useful
#' for bigger data. When `facet = NULL` then single plot is returned showing all localities together.
#' When `facet = physical` sensors with identical physical units are grouped together across localities.
#' Maximal number of physical units (elements) of sensors to be plotted in one
#' plot is two. First element is related to primary and second to secondary y axis. 
#' In case, there are multiple sensors with identical physical on one locality, 
#' they are plotted together for `facet = "locality"` e.g., when you have
#' TMS_T1, TMS_T2, TMS_T3, Thermo_T, and VWC you get plot with 5 lines of different colors and
#' two y axes. Secondary y axes are scaled with calculation `values * scale_coeff`.
#' If scaling coefficient is NULL than function try to detects scale coefficient from
#' physical unit of sensors see [mc_Physical-class]. Scaling is useful when
#' plotting together e.g. temperature and moisture. For native myClim loggers 
#' (TOMST, HOBO U-23) scaling coefficients are pre-defined. 
#' For other cases when plotting two physicals together, 
#' it is better to set scaling coefficients by hand.
#'
#' @template param_myClim_object
#' @param filename output file name/path with the extension - supported formats are .pdf and .png (default NULL)
#'
#' If NULL then the plot is displayed and can be returned into r environment but is not saved to file.
#' @template param_sensors
#' @param scale_coeff scale coefficient for secondary axis (default NULL)
#' @param png_width width for png output (default 1900)
#' @param png_height height for png output (default 1900)
#' @param start_crop POSIXct datetime in UTC for crop data (default NULL)
#' @param end_crop POSIXct datetime in UTC for crop data (default NULL)
#' @template param_use_utc
#' @template param_localities
#' @param facet possible values (`NULL`, `"locality"`, `"physical"`)
#'
#' * `facet = "locality"` each locality is plotted (default)
#' in separate plot in R and separate row in PDF if filename.pdf is provided. 
#' * `facet = "physical"` sensors with  identical physical (see [mc_data_physical]) are grouped together across localities. 
#' * `facet = NULL`, all localities and sensors (max 2 physicals, see details) are plotted in single plot
#' @param color_by_logger If TRUE, the color is assigned by logger to differentiate individual loggers (random colors)
#' if false, the color is assigned by physical. (default FALSE)
#' @return ggplot2 object
#' @examples
#' tms.plot <- mc_filter(mc_data_example_agg, localities = "A6W79")
#' p <- mc_plot_line(tms.plot,sensors = c("TMS_T3","TMS_T1","TMS_moist"))
#' p <- p+ggplot2::scale_x_datetime(date_breaks = "1 week", date_labels = "%W")
#' p <- p+ggplot2::xlab("week")
#' p <- p+ggplot2::scale_color_manual(values=c("hotpink","pink", "darkblue"),name=NULL)
#' @export
mc_plot_line <- function(data, filename=NULL, sensors=NULL,
                         scale_coeff=NULL,
                         png_width=1900, png_height=1900,
                         start_crop=NULL, end_crop=NULL, use_utc=TRUE,
                         localities=NULL,
                         facet="locality",
                         color_by_logger=FALSE) {
    data <- mc_filter(data, localities=localities, sensors=sensors)
    if(!is.null(start_crop) || !is.null(end_crop)) {
        data <- mc_prep_crop(data, start_crop, end_crop)
    }
    sensors_table <- .plot_get_sensors_table(data, facet)
    sensors_table <- .plot_add_coeff_to_sensors_table(sensors_table, scale_coeff, facet)
    data_table <- .plot_reshape_long(data, use_utc=use_utc)
    change_colors <- .plot_get_change_colors(data, data_table, facet, color_by_logger)
    data_table <- .plot_line_edit_data_table(data_table, sensors_table, change_colors, facet)

    plot <- ggplot2::ggplot(data=data_table, ggplot2::aes(x=.data$datetime, y=.data$value_coeff, group=.data$series_name)) +
            ggplot2::geom_line(ggplot2::aes(color=.data$series_name))
    if(!change_colors) {
        plot <- plot + ggplot2::scale_color_manual(values=sensors_table$color)
    } else {
        plot <- plot + ggplot2::scale_color_manual(values=.plot_const_PALETTE)
    }
    plot <- plot + .plot_set_ggplot_line_theme()
    plot <- plot + .plot_line_set_y_axes(sensors_table)

    ggplot_vars <- NULL
    scales <- "fixed"
    if(!is.null(facet)) {
        if(facet == .plot_const_FACET_LOCALITY)
        {
            ggplot_vars <- ggplot2::vars(.data$locality_id)
        } else if(facet == .plot_const_FACET_PHYSICAL) {
            ggplot_vars <- ggplot2::vars(.data$physical)
            scales <- "free"
        }
    }

    if(!is.null(filename)) {
        file_parts <- .plot_get_file_parts(filename)
        if(file_parts[[2]] == "pdf"){
            .plot_print_pdf(filename, list(plot), ggplot_vars, 8, !is.null(facet), scales=scales)
        } else if(file_parts[[2]] == "png") {
            .plot_print_png(filename, plot, png_width, png_height, ggplot_vars, !is.null(facet), scales=scales)
        } else {
            stop(stringr::str_glue("Format of {filename} isn't supported."))
        }
    }
    if(!is.null(facet))
    {
        plot <- plot + ggplot2::facet_grid(rows = ggplot_vars, scales=scales)
    }
    return(plot)
}

.plot_get_sensors_table <- function(data, facet) {
    is_raw_format <- .common_is_raw_format(data)

    sensors_item_function <- function(item) {
        physical_function <- function(sensor) {
            sensor_info <- myClim::mc_data_sensors[[sensor$metadata@sensor_id]]
            if(!is.na(sensor_info@physical)) {
                return(sensor_info@physical)
            }
            if(sensor_info@value_type == "logical") {
                return(sensor_info@value_type)
            }
            sensor$metadata@sensor_id
        }

        color_function <- function(sensor) {
            sensor_info <- myClim::mc_data_sensors[[sensor$metadata@sensor_id]]
            if(is.na(sensor_info@plot_color)) {
                return("black")
            }
            sensor_info@plot_color
        }

        sensor_names <- names(item$sensors)
        physicals <- purrr::map_chr(item$sensors, physical_function)
        colors <- purrr::map_chr(item$sensors, color_function)
        tibble::tibble(sensor=sensor_names, physical=physicals, color=colors)
    }

    raw_locality_function <- function(locality) {
        purrr::map_dfr(locality$loggers, sensors_item_function)
    }

    if(is_raw_format) {
        table <- purrr::map_dfr(data$localities, raw_locality_function)
    } else {
        table <- purrr::map_dfr(data$localities, sensors_item_function)
    }
    table <- dplyr::distinct(table)
    if(!is.null(facet) && facet == .plot_const_FACET_PHYSICAL) {
        table$main_axis <- TRUE
        return(table)
    }
    physicals <- unique(table$physical)
    if(length(physicals) > 2) {
        stop("There are more then two physical units.")
    }
    main_physical <- physicals[[1]]
    if(.model_const_PHYSICAL_T_C %in% physicals) {
        main_physical <- .model_const_PHYSICAL_T_C
    }
    table$main_axis <- (table$physical == main_physical)
    return(table)
}

.plot_add_coeff_to_sensors_table <- function(sensors_table, scale_coeff, facet) {
    physical_table <- dplyr::distinct(dplyr::select(sensors_table, "physical", "main_axis"))

    get_scale_coeff <- function(selector) {
        physical <- physical_table$physical[selector]
        if(physical %in% names(myClim::mc_data_physical)) {
            return(myClim::mc_data_physical[[physical]]@scale_coeff)
        }
        1
    }

    if((is.null(facet) || facet != .plot_const_FACET_PHYSICAL) && is.null(scale_coeff) && nrow(physical_table) > 1) {
        main_scale_coeff <- get_scale_coeff(physical_table$main_axis)
        secondary_scale_coeff <- get_scale_coeff(!physical_table$main_axis)
        scale_coeff <- 1 / main_scale_coeff * secondary_scale_coeff
    }

    sensors_table$coeff <- purrr::map_dbl(sensors_table$main_axis, ~ if(.x) 1 else scale_coeff)
    sensors_table
}

.plot_line_edit_data_table <- function(data_table, sensors_table, change_colors, facet) {
    if(change_colors) {
        data_table$series_name <- paste(data_table$locality_id, data_table$sensor_name)
    } else {
        data_table$series_name <- data_table$sensor_name
    }
    if(any(data_table$logger_index != 1)) {
        data_table$series_name <- paste0(data_table$series_name, " (", data_table$logger_index, ")")
    }

    coeff_list <- as.list(sensors_table$coeff)
    names(coeff_list) <- sensors_table$sensor
    coeff_env <- list2env(coeff_list)
    data_table$value_coeff <- purrr::map2_dbl(data_table$sensor_name, data_table$value, ~ .y * coeff_env[[.x]])
    if(!is.null(facet) && facet == .plot_const_FACET_PHYSICAL)
    {
        join_table <- dplyr::select(sensors_table, "sensor", "physical")
        names(join_table) <- c("sensor_name", "physical")
        data_table <- dplyr::left_join(data_table, join_table, by=dplyr::join_by("sensor_name"))
    }
    return(data_table)
}

.plot_line_set_y_axes <- function(sensors_table) {
    physical_table <- dplyr::distinct(dplyr::select(sensors_table, "physical", "main_axis", "coeff"))
    sec_axis <- .plot_line_get_sec_y_axis(physical_table)
    main_description <- "Values"
    breaks <- ggplot2::waiver()
    labels <- ggplot2::waiver()
    if(length(physical_table$physical[physical_table$main_axis]) == 1)
    {
        main_physical <- physical_table$physical[physical_table$main_axis]
        main_description <- main_physical
        if(main_physical %in% names(myClim::mc_data_physical)) {
            main_description <- myClim::mc_data_physical[[main_physical]]@description
        }
        if(main_physical == .model_const_VALUE_TYPE_LOGICAL){
            breaks <- c(0, 1)
            labels <- c("FALSE", "TRUE")
        }
    }
    return(ggplot2::scale_y_continuous(name=main_description, breaks=breaks, labels=labels, sec.axis=sec_axis))
}

.plot_line_get_sec_y_axis <- function(physical_table) {
    result <- ggplot2::waiver()
    if(!all(physical_table$main_axis)) {
        breaks <- ggplot2::waiver()
        labels <- ggplot2::waiver()
        physical <- physical_table$physical[!physical_table$main_axis]
        coeff <- physical_table$coeff[!physical_table$main_axis]
        description <- physical
        if(physical %in% names(myClim::mc_data_physical)) {
            description <- myClim::mc_data_physical[[physical]]@description
        }
        if(physical == .model_const_VALUE_TYPE_LOGICAL){
            breaks <- c(0, 1)
            labels <- c("FALSE", "TRUE")
        }
        result <- ggplot2::sec_axis(~./coeff, name=description, breaks=breaks, labels=labels)
    }
    return(result)
}

.plot_set_ggplot_line_theme <- function() {
    ggplot2::theme(strip.text.y = ggplot2::element_text(angle = 0),
                   legend.position="bottom",
                   legend.key.width= ggplot2::unit(2, 'cm'),
                   legend.key.height= ggplot2::unit(0.4, 'cm'),
                   panel.border = ggplot2::element_blank())
}

.plot_show_joining_chart <- function(data_table, title, y_label, sizes, highlight_data_table) {
    p <- ggplot2::ggplot(data=data_table, ggplot2::aes(x=.data$datetime, y=.data$value, group=.data$name)) +
        ggplot2::geom_line(ggplot2::aes(color=.data$name, size=.data$size)) +
        ggplot2::scale_size_manual(values = sizes) +
        ggplot2::theme(legend.position="bottom") +
        ggplot2::ggtitle(title) +
        ggplot2::ylab(y_label) +
        ggplot2::xlab("Date") +
        ggplot2::geom_rect(data=highlight_data_table, inherit.aes = FALSE,
                           ggplot2::aes(xmin=.data$start, xmax=.data$end,
                                        ymin=.data$ymin, ymax=.data$ymax, group=.data$group),
                           color="transparent", fill="orange", alpha=0.3) +
        ggplot2::facet_grid(rows = ggplot2::vars(.data$sensor))
    p <- plotly::ggplotly(p)
    print(p)
}

.plot_reshape_long <- function(data, use_utc=TRUE) {
    is_raw_format <- .common_is_raw_format(data)

    sensor_function <- function(locality_id, logger_index, sensor_item, datetime) {
        count <- length(datetime)
        tibble::tibble(locality_id=rep(locality_id, count),
                       logger_index=rep(logger_index, count),
                       sensor_name=rep(sensor_item$metadata@name, count),
                       datetime=datetime,
                       value=sensor_item$values)
    }

    sensors_item_function <- function(locality_id, logger_index, tz_offset, item) {
        tz_offset <- if(use_utc) 0 else tz_offset
        datetime <- .calc_get_datetimes_with_offset(item$datetime, tz_offset)
        tables <- purrr::pmap_dfr(list(locality_id=locality_id, logger_index=logger_index,
                                       sensor_item=item$sensors, datetime=list(datetime)),
                                  sensor_function)
    }

    raw_locality_function <- function(locality) {
        purrr::pmap_dfr(list(locality_id=locality$metadata@locality_id,
                             logger_index=seq_along(locality$loggers),
                             tz_offset=locality$metadata@tz_offset,
                             item=locality$loggers), sensors_item_function)
    }

    if(is_raw_format) {
        result <- purrr::map_dfr(data$localities, raw_locality_function)
    } else {
        result <- purrr::pmap_dfr(list(locality_id=names(data$localities),
                                       logger_index=1,
                                       tz_offset=purrr::map(data$localities, ~ .x$metadata@tz_offset),
                                       item=data$localities), sensors_item_function)
    }
    return(result)
}

.plot_get_change_colors <- function(data, data_table, facet, color_by_logger) {
    if(any(data_table$logger_index != 1) && color_by_logger) {
        return(TRUE)
    }
    if(is.null(facet) || facet != .plot_const_FACET_LOCALITY) {
        return(length(data$localities) > 1)
    }
    return(FALSE)
}

Try the myClim package in your browser

Any scripts or data that you put into this service are public.

myClim documentation built on Oct. 21, 2024, 5:07 p.m.