R/adpcr2ppp.R

In michbur/dpcR: Digital PCR Analysis

#' Convert adpcr to ppp
#'
#' Converts \code{\linkS4class{adpcr}} object to the list of
#' \code{\link[spatstat.geom]{ppp.object}}s.
#'
#' @details
#' Each array is independently converted by \code{\link[spatstat.geom]{ppp}}
#' function. \code{marks} attached to each point represent values contained by
#' the \code{\linkS4class{adpcr}} object.
#'
#' @param input Object of the \code{\linkS4class{adpcr}} class containing data
#' from one or more panels.
#' @param marks If \code{TRUE}, marks values for non-empty partitions. See
#' \code{\link[spatstat.geom]{ppp}} for more in-depth description.
#' @param plot If \code{TRUE}, array is plotted.
#' @return A list containing objects with class
#' \code{\link[spatstat.geom]{ppp.object}} with the length equal to the number of
#' arrays (minimum 1).
#' @author Michal Burdukiewcz, Stefan Roediger.
#' @seealso \code{\link[spatstat.geom]{ppp.object}}, \code{\link[spatstat.geom]{ppp}}.
#' @keywords manip panel
#' @export adpcr2ppp
#' @examples
#'
#' many_panels <- sim_adpcr(
#'   m = 400, n = 765, times = 1000, pos_sums = FALSE,
#'   n_panels = 5
#' )
#'
#' # Convert all arrays to ppp objects
#' adpcr2ppp(many_panels)
#'
#' # Convert all arrays to ppp objects and get third plate
#' third_plate <- adpcr2ppp(many_panels)[[3]]
#'
#' # Convert only third plate to ppp object
#' third_plate2 <- adpcr2ppp(extract_run(many_panels, 3))
#'
#' # Check the class of a new object
#' class(third_plate2)
#'
#' # It's a list with the length 1. The third plate is a first element on this
#' # list
#' class(third_plate2[[1]])
#'
adpcr2ppp <- function(input, marks = TRUE, plot = FALSE) {
  arrays <- adpcr2panel(input, breaks = FALSE)
  lapply(arrays, function(single_array) {
    create_ppp(
      data_vector = single_array, nx_a = ncol(single_array), ny_a = nrow(single_array),
      marks = marks, plot = plot
    )
  })
}


# create_ppp <- function(data_vector, nx_a, ny_a, plot, marks) {
#   #strange syntax, because spatstat.geom use different localizations
#   #than dpcR.
#
#   if(storage.mode(data_vector) == "character") {
#     data_vector <- unlist(lapply(strsplit(data_vector, ","), function(single_dp) {
#       mean(c(as.numeric(substr(single_dp[1], 2, nchar(single_dp[1]))),
#              as.numeric(substr(single_dp[2], 0, nchar(single_dp[2]) - 1))))
#     }))
#   }
#
#   data_points <- which(matrix(data_vector, ncol = nx_a, nrow = ny_a) > 0,
#                        arr.ind = TRUE)
#
#   data_points[, "row"] <- ny_a - data_points[, "row"] + 1
#
#   if (plot)
#     plot(ppp(data_points[, 2], data_points[, 1], c(1, nx_a), c(1, ny_a)))
#   #check if marks are properly assigned
#   if (marks) {
#     ppp(data_points[, 2], data_points[, 1], c(1, nx_a), c(1, ny_a),
#         marks = data_vector[data_vector != 0])
#   } else {
#     ppp(data_points[, 2], data_points[, 1], c(1, nx_a), c(1, ny_a))
#   }
# }

create_ppp <- function(data_vector, nx_a, ny_a, plot, marks) {
  # strange syntax, because spatstat.geom use different localizations
  # than dpcR.
  data_points <- data.frame(
    row = as.vector(row(data_vector)),
    column = as.vector(col(data_vector)),
    value = as.vector(data_vector)
  )

  data_points[, "row"] <- ny_a - data_points[, "row"] + 1

  data_points <- data_points[is.na(data_points[["value"]]) | data_points[["value"]] == 0, ]

  if (plot) {
    plot(ppp(data_points[, 2], data_points[, 1], c(1, nx_a), c(1, ny_a)))
  }
  # check if marks are properly assigned
  if (marks) {
    ppp(data_points[, 2], data_points[, 1], c(1, nx_a), c(1, ny_a),
      marks = data_points[["value"]]
    )
  } else {
    ppp(data_points[, 2], data_points[, 1], c(1, nx_a), c(1, ny_a))
  }
}