R/counting.functions.R

In gusef/IrisSpatialFeatures: A package to extract spatial features based on multiplex IF images

#' DataFrame from all the counts on a per mm2 basis per sample
#'
#' @param x IrisSpatialFeatures ImageSet object.
#' @param ... Additional arguments
#' @examples
#'
#' #loading pre-read dataset
#' dataset <- IrisSpatialFeatures_data
#' counts_per_mm2_sample_data_frame(dataset)
#'
#' @return data frame
#' @docType methods
#' @export
#' @rdname counts_per_mm2_sample_data_frame
setGeneric("counts_per_mm2_sample_data_frame",
           function(x, ...)
               standardGeneric("counts_per_mm2_sample_data_frame"))

#' @rdname counts_per_mm2_sample_data_frame
#' @aliases  counts_per_mm2_sample_data_frame,ANY,ANY-method
setMethod(
    "counts_per_mm2_sample_data_frame",
    signature = "ImageSet",
    definition = function(x) {
        v <- counts_per_mm2_data_frame(x)
        v <- v %>% group_by(sample,marker) %>%
                   summarize(mean_density=mean(density,na.rm=TRUE),
                             measured_count=sum(!is.na(density)),
                             frame_count=n(),
                             stddev=sd(density,na.rm=TRUE),
                             stderr=sd(density,na.rm=TRUE)/sqrt(sum(!is.na(density)))
        )
        return(v)
    }
)



#' DataFrame from all the counts on a per mm2 basis non-collapsed
#'
#' @param x IrisSpatialFeatures ImageSet object.
#' @param ... Additional arguments
#' @examples
#'
#' #loading pre-read dataset
#' dataset <- IrisSpatialFeatures_data
#' counts_per_mm2_data_frame(dataset)
#'
#' @return data frame
#' @docType methods
#' @export
#' @rdname counts_per_mm2_data_frame
setGeneric("counts_per_mm2_data_frame",
           function(x, ...)
               standardGeneric("counts_per_mm2_data_frame"))

#' @rdname counts_per_mm2_data_frame
#' @aliases counts_per_mm2_data_frame,ANY,ANY-method
setMethod(
    "counts_per_mm2_data_frame",
    signature = "ImageSet",
    definition = function(x) {
        cnts <- get_counts_per_mm2_noncollapsed(x)
        dfs <- lapply(names(cnts),function(sample){
            mat <- cnts[[sample]]
            df <- melt(mat)
            colnames(df) <- c('frame','marker','density')
            df$sample <- sample
            df <- df[,c('sample','frame','marker','density')]
            df$sample <- as.character(df$sample)
            df$frame <- as.character(df$frame)
            return(df)
        })
        v <- do.call(rbind,dfs)
        return(v)
    }
)

#' DataFrame from all the counts per frame
#'
#' @param x IrisSpatialFeatures ImageSet object.
#' @param ... Additional arguments
#' @examples
#'
#' #loading pre-read dataset
#' dataset <- IrisSpatialFeatures_data
#' counts_data_frame(dataset)
#'
#' @return data frame
#' @docType methods
#' @export
#' @rdname counts_data_frame
setGeneric("counts_data_frame",
           function(x, ...)
               standardGeneric("counts_data_frame"))

#' @rdname counts_data_frame
#' @aliases counts_data_frame,ANY,ANY-method
setMethod(
    "counts_data_frame",
    signature = "ImageSet",
    definition = function(x) {
        cdata <- as.data.frame(x) %>% group_by(frame,sample,marks) %>% summarize(count=n())
        cdata$marks <- as.character(cdata$marks)
        #marks <- as.data.frame(unique(cdata$marks))
        marks <- as.data.frame(as.character(unique(levels(x@samples[[1]]@coordinates[[1]]@ppp$marks))))
        colnames(marks) <- "marks"
        subjects <- cdata %>% select(sample,frame) %>% distinct()
        all <- subjects %>% merge(marks)
        all$marks <- as.character(all$marks)
        cnts <- all %>% left_join(cdata, by=c("sample","frame","marks")) %>% replace(.,is.na(.),0)
        return(cnts)
    }
)

#' DataFrame from all the counts per frame
#'
#' @param x IrisSpatialFeatures ImageSet object.
#' @param ... Additional arguments
#' @examples
#'
#' #loading pre-read dataset
#' dataset <- IrisSpatialFeatures_data
#' counts_sample_data_frame(dataset)
#'
#' @return data frame
#' @docType methods
#' @export
#' @rdname counts_sample_data_frame
setGeneric("counts_sample_data_frame",
           function(x, ...)
               standardGeneric("counts_sample_data_frame"))

#' @rdname counts_sample_data_frame
#' @aliases counts_sample_data_frame,ANY,ANY-method
setMethod(
    "counts_sample_data_frame",
    signature = "ImageSet",
    definition = function(x) {
        cnts <- counts_data_frame(x) %>% group_by(sample,marks) %>% summarize(frame_count=n(),total_count=sum(count),mean_count=mean(count),stddev=sd(count),stderr=sd(count)/sqrt(n()))
        return(cnts)
    }
)

##################################
####### Get all count data


setGeneric("get_counts_collapsed",
           function(x, ...)
               standardGeneric("get_counts_collapsed"))
setMethod(
    "get_counts_collapsed",
    signature = "ImageSet",
    definition = function(x) {
        combined <- sapply(x@counts, colSums, na.rm = TRUE)
        nams <- x@markers
        if (class(combined) != 'matrix') {
            counter <- rep(0, length(nams))
            names(counter) <- nams
            counts <- sapply(combined, extractCountsF, counter)
        } else{
            counts <- combined
            rownames(counts) <- nams
        }
        counts <- counts[order(rownames(counts)), ]

        return(counts)
    }
)



#' Get all the counts on a per mm2 basis non-collapsed
#'
#' @param x IrisSpatialFeatures ImageSet object.
#' @param ... Additional arguments
#' @examples
#'
#' #loading pre-read dataset
#' dataset <- IrisSpatialFeatures_data
#' get_counts_per_mm2_noncollapsed(dataset)
#'
#' @return IrisSpatialFeatures ImageSet object.
#' @docType methods
#' @export
#' @rdname get_counts_per_mm2_noncollapsed
setGeneric("get_counts_per_mm2_noncollapsed",
           function(x, ...)
               standardGeneric("get_counts_per_mm2_noncollapsed"))

#' @rdname get_counts_per_mm2_noncollapsed
#' @aliases get_counts_per_mm2_noncollapsed,ANY,ANY-method
setMethod(
    "get_counts_per_mm2_noncollapsed",
    signature = "ImageSet",
    definition = function(x) {
        sizes <- lapply(x@samples,
                        function(y)
                            sapply(y@coordinates,
                                   function(z)
                                       z@size_in_px))

        #counts per mm2
        counts <- lapply(x@counts,
                         function(y, z)
                             y / (z@microns_per_pixel ^ 2),
                         x)
        samps <- names(sizes)
        counts <- lapply(samps,
                         function(y, counts, sizes)
                             1000000 * sweep(counts[[y]], 1, sizes[[y]], '/'),
                         counts,
                         sizes)
        names(counts) <- samps

        return(counts)
    }
)


#' Get all the counts on a per mm2 basis
#' @param x An IrisSpatialFeatures ImageSet object
#' @param digits Number of digits that are shown in the output (default: 2)
#' @param blank (default: FALSE)
#' @param ... Additional arguments
#' @return counts per mm2 per sample, collapsing each coordinate and returning
#'         mean and standard error
#'
#' @examples
#'
#' #loading pre-read dataset
#' dataset <- IrisSpatialFeatures_data
#' get_counts_per_mm2(dataset)
#'
#' @docType methods
#' @export
#' @importFrom stats sd
#' @rdname get_counts_per_mm2
setGeneric("get_counts_per_mm2", function(x, ...)
    standardGeneric("get_counts_per_mm2"))

#' @rdname get_counts_per_mm2
setMethod(
    "get_counts_per_mm2",
    signature = "ImageSet",
    definition = function(x, digits = 2, blank = FALSE) {
        counts <- get_counts_per_mm2_noncollapsed(x)
        if (length(x@counts) > 1) {
            means <- sapply(counts, colMeans, na.rm = TRUE)
            se <- sapply(counts, function(x)
                apply(x, 2,
                      function(y)
                          sd(y, na.rm = TRUE) / sqrt(length(y[!is.na(y)]))))
            res <- means
            if (!blank) {
                for (i in 1:ncol(means)) {
                    res [, i] <- paste(format(means[, i], digits = digits),
                                       '+/-',
                                       format(se[, i], digits = digits))
                }
            }
        } else if (!blank) {
            res <- format(counts, digits = digits)
        } else{
            res <- counts
        }
        return(res)
    }
)


#' Get ratio of counts between two markers
#'
#' @param x An IrisSpatialFeatures object
#' @param marker1 First cell-type.
#' @param marker2 Second cell-type.
#' @param digits Number of digits that should be shown in the the results.
#'        (Default: 2)
#' @param ... Additional arguments.
#' @return Count ratio between two markers
#'
#' @docType methods
#' @importFrom stats sd
#' @rdname get_count_ratios
#' @export
#' @examples
#'
#' #loading pre-read dataset
#' dataset <- IrisSpatialFeatures_data
#' get_count_ratios(dataset,'SOX10+ PDL1-','SOX10+ PDL1+')
setGeneric("get_count_ratios",
           function(x, ...)
               standardGeneric("get_count_ratios"))

#' @rdname get_count_ratios
#' @aliases get_count_ratios,ANY,ANY-method
setMethod(
    "get_count_ratios",
    signature = "ImageSet",
    definition = function(x, marker1, marker2, digits = 2) {
        ratios <- sapply(x@counts,
                         function(x, m1, m2)
                             x[, m1] / x[, m2], marker1, marker2)
        for (idx in 1:length(ratios)) {
            ratios[[idx]][is.infinite(ratios[[idx]])] <- NA
        }
        means <- sapply(ratios, mean, na.rm = TRUE)
        se <- sapply(ratios,
                     function(x)
                         sd(x, na.rm = TRUE) / sqrt(length(x[!is.na(x)])))
        res <- paste(format(means, digits = digits),
                     '+/-',
                     format(se, digits = digits))
        names(res) <-
            sapply(x@samples, function(x)
                x@sample_name)
        return(res)
    }
)

setGeneric("extract_counts", function(x, ...)
    standardGeneric("extract_counts"))
setMethod(
    "extract_counts",
    signature = "ImageSet",
    definition = function(x) {
        counts <- lapply(x@samples, extract_counts_sample)
        nams <- sort(unique(unlist(lapply(
            counts, colnames
        ))))
        for (i in 1:length(counts)) {
            if (nrow(counts[[i]]) == 1) {
                temp <- t(as.matrix(counts[[i]][,match(nams,
                                                colnames(counts[[i]]))]))
                rownames(temp) <- rownames(counts[[i]])
                counts[[i]] <- temp
            } else{
                counts[[i]] <- counts[[i]][, match(nams,
                                                   colnames(counts[[i]]))]
            }

            colnames(counts[[i]]) <- nams
            counts[[i]][is.na(counts[[i]])] <- 0
        }
        x@counts <- counts
        x@markers <- nams
        return(x)
    }
)

setGeneric("extract_counts_sample",
           function(x, ...)
               standardGeneric("extract_counts_sample"))
setMethod(
    "extract_counts_sample",
    signature = "Sample",
    definition = function(x) {
        counts <- lapply(x@coordinates, function(x)
            table(x@ppp$marks))
        nams <- unique(unlist(lapply(counts, names)))
        counter <- rep(0, length(nams))
        names(counter) <- nams
        counts <- t(sapply(counts, extractCountsF, counter))
        return(counts)
    }
)

#helperfunction to count the features making sure missing celltypes don't
#  cause problems
extractCountsF <- function(x, counter) {
    counter[match(names(x), names(counter))] <- x
    return(counter)
}

setGeneric("get_counts_noncollapsed",
           function(x, ...)
               standardGeneric("get_counts_noncollapsed"))
setMethod(
    "get_counts_noncollapsed",
    signature = "ImageSet",
    definition = function(x) {
        counts <- x@counts
        nams <- unique(unlist(lapply(counts, colnames)))
        standardize <- function(x, nams) {
            y <- matrix(0, nrow = nrow(x), ncol = length(nams))
            colnames(y) <- nams
            rownames(y) <- rownames(x)
            y[, colnames(x)] <- x
            return(y)
        }
        counts <- lapply(counts, standardize, nams)
        return(counts)
    }
)