R/plot_pOutbreak.R

In MESuRS-Lab/mwss: Stochastic simulations of infectious disease spread in healthcare systems structured as a networked metapopulation

#' Plot the probability of epidemics per ward
#'
#' @description \code{plot_pOutbreak} returns a network plot of the wards whose colors represent
#' the probability of epidemics. This probability is calculated as the proportion of simulations
#' where at least \code{outb_Thhold} cases occurred (including professionals and patients cases).
#' Node size is define by the patient population size.
#' Connection between size depends on values in the contact matrix.
#'
#'
#' @usage plot_pOutbreak(trajmwss,
#' pop_size_P,
#' matContact,
#' outb_Thhold = 1,
#' layout = "with_fr",
#' vertexsize = 0.5,
#' vertexlabelsize = 0.03,
#' edgearrowsize = 0.4,
#' maxcolors = FALSE,
#' addtitle = FALSE,
#' verbose = TRUE)
#'
#' @param trajmwss List. Trajectories generated by \code{multisim} function.
#' @param pop_size_P Numerical vector. Define patient population sizes.
#' @param matContact Square matrix. Report the proportion of time spent by health care workers in the different wards.
#' @param outb_Thhold Integer. Defines the minimal number of cases requested to define an epidemic (default is 1).
#' @param layout String. Graph layout (details: ? igraph::layout_). Default is "with_fr". Options: "as_star","as_tree","in_circle","nicely","on_grid","on_sphere", "randomly","with_dh","with_fr","with_gem","with_graphopt", "with_kk","with_lgl", "with_mds", "with_sugiyama"
#' @param vertexsize Integer. Defines the nodes/ward size (default is 0.5).
#' @param vertexlabelsize Integer. Defines the nodes/ward names size (default is 0.03).
#' @param edgearrowsize Integer. Defines the edge arrows size (default is 0.4).
#' @param addtitle Logical. Optional title (default is FALSE).
#' @param maxcolors Integer. Limit the number of colors displayed in the legend (default is FALSE).
#' @param verbose Logical. Optional messages (default is TRUE).
#'
#' @importFrom intergraph asIgraph
#' @importFrom scales rescale
#' @importFrom igraph V
#' @importFrom igraph V<-
#' @importFrom network as.network
#' @importFrom grDevices heat.colors
#' @importFrom graphics legend
#' @importFrom graphics title
#' @importFrom data.table ':='
#' @importFrom igraph layout_
#' @importFrom igraph as_star
#' @importFrom igraph as_tree
#' @importFrom igraph in_circle
#' @importFrom igraph nicely
#' @importFrom igraph on_grid
#' @importFrom igraph on_sphere
#' @importFrom igraph randomly
#' @importFrom igraph with_dh
#' @importFrom igraph with_fr
#' @importFrom igraph with_gem
#' @importFrom igraph with_graphopt
#' @importFrom igraph with_kk
#' @importFrom igraph with_lgl
#' @importFrom igraph with_mds
#' @importFrom igraph with_sugiyama
#'
#' @return Igraph plot.
#'
#' @examples
#' data("toydata")
#' list2env(toydata,envir=.GlobalEnv)
#' gdata <- build_gdata()
#'
#' model <- mwss(ward_names, pop_size_P, pop_size_H, nVisits, LS, gdata, tSim = 30)
#' results <- multisim(model, 5, ward_names)
#'
#' matContact <- randomContacts(pop_size_H, ward_names)$contactMat
#' plot_pOutbreak(results,
#' pop_size_P,
#' matContact,
#' outb_Thhold = 1,
#' layout = "nicely",
#' vertexsize = 0.5,
#' vertexlabelsize = 0.03,
#' edgearrowsize = 0.4,
#' maxcolors = FALSE,
#' addtitle = TRUE,
#' verbose = FALSE)
#'
#' @export


plot_pOutbreak <-
  function(trajmwss,
           pop_size_P,
           matContact,
           outb_Thhold = 1,
           layout = "with_fr",
           vertexsize = 0.5,
           vertexlabelsize = 0.03,
           edgearrowsize = 0.4,
           maxcolors = FALSE,
           addtitle = FALSE,
           verbose = TRUE) {

    # Check

if(!layout %in% c("as_star","as_tree","in_circle","nicely","on_grid","on_sphere",
                 "randomly","with_dh","with_fr","with_gem","with_graphopt",
                 "with_kk","with_lgl", "with_mds", "with_sugiyama")){
  warning("Only the following layout have been integrated yet: \"as_star\",\"as_tree\",\"in_circle\",\"nicely\",\"on_grid\",\"on_sphere\", \"randomly\",\"with_dh\",\"with_fr\",\"with_gem\",\"with_graphopt\", \"with_kk\",\"with_lgl\", \"with_mds\", \"with_sugiyama\". The default layout: \"nicely\" will be used")
  layout <- "nicely"
  }
    g <-
      plot_connectivity(matContact,
                        pop_size_P,
                        netobj = TRUE,
                        verbose = verbose)



    g %<>% asIgraph(.)

    # probability of outbreak in ward
    pOB <- keyoutput(trajmwss,
                   scale = 1,
                   focus = "infections",
                   outb_Thhold = outb_Thhold)$p_outbreak %>% .[, perc_outbreak] %>% multiply_by(100)


    if (0 %in% pOB)
      colorspOB <- pOB %>% rescale(., to = c(1, 100)) else
      colorspOB <- pOB %>% rescale(., to = c(5, 100))

    colorspOB %<>% sapply(., function(vertexColor) {
      rev(heat.colors(100))[vertexColor]
    })

    V(g)$colorspOB <- colorspOB

    eval(parse(text=(paste0("coords <- layout_(g, ", layout, "())"))))

    p <- plot(
      g,
      vertex.label        = V(g)$vertex.names,
      vertex.size         = pop_size_P * vertexsize,
      vertex.label.cex    = pop_size_P * vertexlabelsize,
      edge.arrow.size     = edgearrowsize,
      vertex.frame.color  = "black",
      vertex.label.color  = "black",
      vertex.color        = V(g)$colorspOB,
      edge.curved         = FALSE,
      vertex.label.family = "sans",
      layout = coords
    )


    if (isTRUE(addtitle))
      title(main = paste("Percentage of simulations with \n at least",
                    outb_Thhold,
                    "nosocomial infections"))


    keep <-
      order(round(pOB, 2))[!duplicated(round(pOB, 2)[order(round(pOB, 2))])]

    dfleg <- data.frame(legendlab = pOB[keep] %>% round(., 2) %>% paste0(., "%"),
                        legendcol = colorspOB[keep]) %>% .[!duplicated(.$legendlab), ]


    if (!isFALSE(maxcolors) & nrow(dfleg) > maxcolors) {

      dfleg$valuesint <- pOB[keep] %>% round(., 2)

      lengthout <- nrow(dfleg)
      ncolors <- dfleg$valuesint

      while ((ncolors %>% unique %>% length) > maxcolors) {
        lengthout %<>% magrittr::subtract(1)
        ncolors <-
          pOB[keep] %>% findInterval(., seq(min(.), max(.), length.out = lengthout))
      }

      dfleg$interv <- ncolors
      setDT(dfleg)[, legendlab := paste0(max(valuesint), "%"), by = interv]


      dfleg %<>% .[ !duplicated(.[, c("legendlab")], fromLast=T),]
    }


    legend(
      "topleft",
      bty = "n",
      cex = 1,
      pt.cex = 2,
      legend = dfleg$legendlab,
      col = "black",
      pt.bg = dfleg$legendcol,
      pch = 21,
      border = NA
    )

  }