R/elaborator_plot_ref_pattern.R

In elaborator: A 'shiny' Application for Exploring Laboratory Data

#' Generates the reference-value based pattern analysis plots in the shiny app elaborator
#'
#' @description
#' Generates diagrams showing the frequency of normal and abnormal values at each visit of a study separately by treatment group and laboratory parameter according to the reference-value based pattern analysis.
#'
#' @param data data set
#' @param criterion criterion for defining whether abnormal values are defined as values below the lower limit of normal (less), above the upper limit of normal (greater) or either above the upper limit of normal or below the lower limit of normal (within)
#' @param fontsize font size of numbers printed inside the circles
#' @param sorting_vector vector of laboratory parameter names in the order in which laboratory parameters are presented in the output
#' @param abnormal_value_factor numeric which is multiplied with upper and/or lower limit of normal for defining abnormal values; can only take positive values.
#'
#' @return No return value, called to plot the reference-based value pattern.
#'
#' @keywords internal


elaborator_plot_ref_pattern <- function(
  data,
  criterion,
  fontsize = 0.6,
  sorting_vector = as.character(unique(data[, "PARAMCD"])),
  abnormal_value_factor = 1
) {
  variable <- treat <- . <- subj <- upb <- upb2 <- lwb <- lwb2 <- difference_tmp <- dimension <- difference <- dimension2 <- NULL

  ColorBG <- "#E2F3F2"
  colRvbpPos <- "#2fb39f"
  colRvbpNeg <- "#f78300"

  if (length((unique(data$TRTP))) == 0 |
      length(unique(data[, "PARAMCD"])) == 0) {

    on_ex <- graphics::par("mfrow", "bty","mar","oma","bg")
    on.exit(graphics::par(on_ex))
    graphics::par(mfrow = c(1, 1),
                  bty = "n",
                  mar = c(1, 1, 1, 1),
                  oma = c(0, 0, 0, 0),
                  bg = ColorBG)
    graphics::plot(NULL, NULL, ylim = c(0, 1), xlim = c(0, 1), axes = FALSE, ylab = "", xlab = "")
    graphics::rect(xleft = graphics::grconvertX(0, 'ndc', 'user'), xright = graphics::grconvertX(1,'ndc', 'user'),
                   ybottom = graphics::grconvertY(0,'ndc', 'user'), ytop = graphics::grconvertY(1,'ndc', 'user'),
                   border = NA, col = ColorBG, xpd = TRUE)
    graphics::text(0.5, 0.5, paste0("No values for this Treatment"))
  } else {

    if (length(unique(data$PARAMCD))*length(unique(data$TRTP)) > 1) {
      shiny::withProgress(message = paste0('generating ', length(unique(data$PARAMCD))*length(unique(data$TRTP)),' Plots ...'), value = 0, {
        shiny::incProgress(0, detail = paste(""))

        number <- function(p){
          as.vector((as.matrix(p) %*% as.matrix(2^((p %>% dim %>% .[2]-1):0))))
        }

        number2 <- function(p){
          res <- c()
          for(i in 1:nrow(p)){
            f <- 2^((length(p[i,]) - 1):0)
            res[i] <- sum(p[i, ] * f)
          }
          return(res)
        }

        D <- data.frame(subj = data$SUBJIDN,
                        treat = data$TRTP,
                        variable = data$PARAMCD,
                        time = as.numeric(data$AVISIT),
                        value2 = data$LBORRES,
                        lwb  = as.numeric(data$LBORNRLO),
                        upb  = as.numeric(data$LBORNRHI))

        if(abnormal_value_factor >= 0 & abnormal_value_factor != 1) {
          D$lwb2 <- D$lwb * abnormal_value_factor
          D$upb2 <- D$upb * abnormal_value_factor
        }

        if (criterion == "within") {
          if (abnormal_value_factor == 1) {
            D$value = as.numeric(!((D$lwb <= D$value2) & (D$value2 <= D$upb)))
          } else {
            D$value = as.numeric(!((D$lwb2 <= D$value2) & (D$value2 <= D$upb2)))
          }
        } else if (criterion == "less") {
          if (abnormal_value_factor == 1) {
            D$value = as.numeric(!(D$lwb <= D$value2))
          } else {
            D$value = as.numeric(!(D$lwb2 <= D$value2))
          }
        } else if (criterion == "greater") {
          if (abnormal_value_factor == 1) {
            D$value = as.numeric(!(D$value2 <= D$upb))
          } else {
            D$value = as.numeric(!(D$value2 <= D$upb2))
          }
        }

        reducedData <- D[,c("subj", "treat", "variable", "time", "value")]

        Treats <- levels(reducedData$treat)

        reducedData_wide <- reshape2::dcast(reducedData, treat + variable + subj ~ time, drop = TRUE)

        reducedData_long <- reducedData_wide %>%
          dplyr::group_by(treat, variable) %>%
          dplyr::select(-subj) %>%
          tidyr::nest() %>%
          dplyr::mutate(difference_tmp = purrr::map(data, ~ .[, colSums(is.na(.)) != nrow(.)])) %>%
          dplyr::mutate(dimension = purrr::map(difference_tmp, ~ dim(.)[2])) %>%
          dplyr::mutate(difference = purrr::map(difference_tmp, ~ stats::na.omit(.))) %>%
          dplyr::select(-c(data, difference_tmp)) %>%
          dplyr::mutate(dimension2 = dimension %>%
                          unlist) %>%
          dplyr::mutate(mz = purrr::map(difference, ~ number(.)))

        sortinput <- sorting_vector[sorting_vector %in% reducedData_long$variable]

        graphics::layout(matrix(1:(length(Treats) * length(sortinput)), length(Treats), length(sortinput)))

        on_ex <- graphics::par("mfrow","mai","xaxs","yaxs","bg","fg","font","font.axis","font.lab","font.main","font.sub","ps","cex","family")
        on.exit(graphics::par(on_ex))
        graphics::par(mfrow = c(length((unique(data$TRTP))), length(unique(sortinput))),
                      mai = rep(0, 4), xaxs = "i", yaxs = "i",
                      bg = ColorBG,
                      fg = grDevices::rgb(140, 140, 140, maxColorValue = 255),
                      font = 1, font.axis = 1, font.lab = 1, font.main = 1, font.sub = 1,
                      ps = 5, cex = 1,
                      family = "sans")

        for (treatments in Treats) {
          for (labvalues in sortinput) {

            dimension_tmp <- reducedData_long %>%
              dplyr::filter(variable == labvalues , treat == treatments) %>%
              dplyr::pull(dimension2)

            if (length(dimension_tmp) == 0) {
              graphics::plot(NULL, NULL, ylim = c(0, 1), xlim = c(0, 1), axes = FALSE, ylab = "", xlab = "")
              graphics::rect(xleft = graphics::grconvertX(0, 'ndc', 'user'), xright = graphics::grconvertX(1, 'ndc', 'user'),
                             ybottom = graphics::grconvertY(0,'ndc','user'), ytop = graphics::grconvertY(1, 'ndc', 'user'),
                             border = NA, col = ColorBG, xpd = TRUE)
              graphics::text(0.5, 0.5, paste0("No values for this Treatment"))

            } else {

              index <- 0:(2^dimension_tmp - 1)
              List_index <- lapply(index, function(i) elaborator_calculate_ref_pattern(i, dimension_tmp))

              CombinationMatrix <- matrix(unlist(List_index), 2^dimension_tmp, dimension_tmp, byrow = TRUE)
              colnames(CombinationMatrix) = paste("M", 1:dimension_tmp, sep = "")

              mg <- unlist(lapply(1:2^dimension_tmp, function(i) sum(CombinationMatrix[i,])))

              CombinationMatrix <- data.frame(CombinationMatrix, index)
              CombinationMatrix <- data.frame(CombinationMatrix[order(CombinationMatrix$index, decreasing = TRUE), ] , number = rep(0, 2^dimension_tmp))

              reducedData_long_tmp <- reducedData_long %>%
                dplyr::filter(variable == labvalues , treat == treatments)

              if (length(unlist(reducedData_long_tmp$mz)) > 0) {
                table_number <- table(unlist(reducedData_long_tmp$mz))
                q <- as.numeric(names(table_number))

                CombinationMatrix$number[elaborator_derive_equal_values(q, CombinationMatrix$index)] <- table_number
                #all
                elaborator_draw_ref_pattern(pattern_Matrix = CombinationMatrix, fontsize = fontsize, number_columns = dimension_tmp)

              } else {
                graphics::text((dimension_tmp - 1) / 2, (2^dimension_tmp + 1) / 2, "No Data Available!")
              }
            }
            if (treatments == Treats[1]) {
              graphics::text(0, (2^dimension_tmp + 1) - 1, labvalues, cex = 2)
            }

            if (labvalues == sortinput[1]) {
              graphics::text(-0.5, (2^dimension_tmp + 1) / 2, treatments, srt = 90, cex = 2)
            }


            shiny::incProgress(1/(length(sortinput) * length(Treats)), detail = paste(""))
          }
          shiny::incProgress(1/length(sortinput), detail = paste(""))
        }
        shiny::incProgress(0, detail = paste("done!"))
      })
    } else {

      number <- function(p) {
        as.vector((as.matrix(p) %*% as.matrix(2^((p %>% dim %>% .[2]-1):0))))
      }

      number2 <- function(p){
        res <- c()
        for(i in 1:nrow(p)){
          f <- 2^((length(p[i,]) - 1):0)
          res[i] <- sum(p[i, ] * f)
        }
        return(res)
      }

      D <- data.frame(subj = data$SUBJIDN,
                      treat = data$TRTP,
                      variable = data$PARAMCD,
                      time = as.numeric(data$AVISIT),
                      value2 = data$LBORRES,
                      lwb  = as.numeric(data$LBORNRLO),
                      upb  = as.numeric(data$LBORNRHI))


      if(abnormal_value_factor >= 0 & abnormal_value_factor != 1) {
        D$lwb2 <- D$lwb * abnormal_value_factor
        D$upb2 <- D$upb * abnormal_value_factor
      }

      if (criterion == "within") {
        if (abnormal_value_factor == 1) {
          D$value = as.numeric(!((D$lwb <= D$value2) & (D$value2 <= D$upb)))
        } else {
          D$value = as.numeric(!((D$lwb2 <= D$value2) & (D$value2 <= D$upb2)))
        }
      } else if (criterion == "less") {
        if (abnormal_value_factor == 1) {
          D$value = as.numeric(!(D$lwb <= D$value2))
        } else {
          D$value = as.numeric(!(D$lwb2 <= D$value2))
        }
      } else if (criterion == "greater") {
        if (abnormal_value_factor == 1) {
          D$value = as.numeric(!(D$value2 <= D$upb))
        } else {
          D$value = as.numeric(!(D$value2 <= D$upb2))
        }
      }


      reducedData <- D[,c("subj", "treat", "variable", "time", "value")]

      Treats <- levels(reducedData$treat)

      reducedData_wide <- reshape2::dcast(reducedData, treat + variable + subj ~ time, drop = TRUE)

      reducedData_long <- reducedData_wide %>%
        dplyr::group_by(treat, variable) %>%
        dplyr::select(-subj) %>%
        tidyr::nest() %>%
        dplyr::mutate(difference_tmp = purrr::map(data, ~ .[, colSums(is.na(.)) != nrow(.)])) %>%
        dplyr::mutate(dimension = purrr::map(difference_tmp, ~ dim(.)[2])) %>%
        dplyr::mutate(difference = purrr::map(difference_tmp, ~ stats::na.omit(.))) %>%
        dplyr::select(-c(data, difference_tmp)) %>%
        dplyr::mutate(dimension2 = dimension %>%
                        unlist) %>%
        dplyr::mutate(mz = purrr::map(difference, ~ number(.)))

      sortinput <- sorting_vector[sorting_vector %in% reducedData_long$variable]

      graphics::layout(matrix(1:(length(Treats) * length(sortinput)), length(Treats), length(sortinput)))

      on_ex <- graphics::par("mfrow","mai","xaxs","yaxs","bg","fg","font","font.axis","font.lab","font.main","font.sub","ps","cex","family")
      on.exit(graphics::par(on_ex))
      graphics::par(mfrow = c(length((unique(data$TRTP))), length(unique(sortinput))),
                    mai = rep(0, 4), xaxs = "i", yaxs = "i",
                    bg = ColorBG,
                    fg = grDevices::rgb(140, 140, 140, maxColorValue = 255),
                    font = 1, font.axis = 1, font.lab = 1, font.main = 1, font.sub = 1,
                    ps = 5, cex = 1,
                    family = "sans")

      for (treatments in Treats) {
        for (labvalues in sortinput) {

          dimension_tmp <- reducedData_long %>%
            dplyr::filter(variable == labvalues , treat == treatments) %>%
            dplyr::pull(dimension2)

          if (length(dimension_tmp) == 0) {
            graphics::plot(NULL, NULL, ylim = c(0, 1), xlim = c(0, 1), axes = FALSE, ylab = "", xlab = "")
            graphics::rect(xleft = graphics::grconvertX(0, 'ndc', 'user'), xright = graphics::grconvertX(1, 'ndc', 'user'),
                           ybottom = graphics::grconvertY(0,'ndc','user'), ytop = graphics::grconvertY(1, 'ndc', 'user'),
                           border = NA, col = ColorBG, xpd = TRUE)
            graphics::text(0.5, 0.5, paste0("No values for this Treatment"))

          } else {

            index <- 0:(2^dimension_tmp - 1)
            List_index <- lapply(index, function(i) elaborator_calculate_ref_pattern(i, dimension_tmp))

            CombinationMatrix <- matrix(unlist(List_index), 2^dimension_tmp, dimension_tmp, byrow = TRUE)
            colnames(CombinationMatrix) = paste("M", 1:dimension_tmp, sep = "")

            mg <- unlist(lapply(1:2^dimension_tmp, function(i) sum(CombinationMatrix[i,])))

            CombinationMatrix <- data.frame(CombinationMatrix, index)
            CombinationMatrix <- data.frame(CombinationMatrix[order(CombinationMatrix$index, decreasing = TRUE), ] , number = rep(0, 2^dimension_tmp))

            reducedData_long_tmp <- reducedData_long %>%
              dplyr::filter(variable == labvalues , treat == treatments)

            if (length(unlist(reducedData_long_tmp$mz)) > 0) {
              table_number <- table(unlist(reducedData_long_tmp$mz))
              q <- as.numeric(names(table_number))

              CombinationMatrix$number[elaborator_derive_equal_values(q, CombinationMatrix$index)] <- table_number

              elaborator_draw_ref_pattern(pattern_Matrix = CombinationMatrix, fontsize = fontsize, number_columns = dimension_tmp)

              text(
                x = grconvertX(0, "npc", "user"),
                y = grconvertY(.2, "npc", "user"),
                labels = paste0("Upper limit normal:",
                                paste(
                                  D %>%
                                    dplyr::filter(treat == treatments & variable == labvalues) %>%
                                    dplyr::pull(upb) %>%
                                    unique(),
                                  collapse = ", "
                                )
                ),
                adj = 0,
                cex = 2
              )

              text(
                x = grconvertX(0, "npc", "user"),
                y = grconvertY(.15, "npc", "user"),
                labels = paste0("Lower limit normal:",
                                paste(
                                  D %>%
                                    dplyr::filter(treat == treatments & variable == labvalues) %>%
                                    dplyr::pull(lwb) %>%
                                    unique(),
                                  collapse = ", "
                                )
                ),
                adj = 0,
                cex = 2
              )

              if(abnormal_value_factor >= 0 & abnormal_value_factor != 1) {
                if (!criterion == "less") {
                  text(
                    x = grconvertX(0, "npc", "user"),
                    y = grconvertY(.1, "npc", "user"),
                    labels = paste0("Upper lower normal times factor (", abnormal_value_factor, ") : ",
                                    paste(
                                      D %>%
                                        dplyr::filter(treat == treatments & variable == labvalues) %>%
                                        dplyr::pull(upb2) %>%
                                        unique() %>%
                                        round(2),
                                      collapse = ", "
                                    )
                    ),
                    adj = 0,
                    col = "red",
                    cex = 2
                  )
                }
                if (!criterion == "greater") {
                  text(
                    x = grconvertX(0, "npc", "user"),
                    y = grconvertY(.05, "npc", "user"),
                    labels = paste0("Lower limit normal times factor (", abnormal_value_factor, ") : ",
                                    paste(
                                      D %>%
                                        dplyr::filter(treat == treatments & variable == labvalues) %>%
                                        dplyr::pull(lwb2) %>%
                                        unique() %>%
                                        round(2),
                                      collapse = ", "
                                    )
                    ),
                    adj = 0,
                    col = "red",
                    cex = 2
                  )
                }
              }
            } else {
              graphics::text((dimension_tmp - 1) / 2, (2^dimension_tmp + 1) / 2, "No Data Available!")
            }
          }
          if (treatments == Treats[1]){
            graphics::text(0, (2^dimension_tmp + 1) - 1, labvalues, cex = 2)
          }

          if (labvalues == sortinput[1]){
            graphics::text(-0.5, (2^dimension_tmp + 1) / 2, treatments, srt = 90, cex = 2)
          }
        }
      }
    }
  }
}