inst/shinyTemplate/functions.R

In cannin/rcellminer: rcellminer: Molecular Profiles, Drug Response, and Chemical Structures for the NCI-60 Cell Lines

#' Title
#'
#' @param sampleData
#' @param typeLevelSeparator
#'
#' @return value
#'
#' @examples
#' NULL
getTissueToSamplesMap <- function(sampleData, typeLevelSeparator = ":"){
	stopifnot(all(!duplicated(sampleData$Name)))
	rownames(sampleData) <- sampleData$Name
	tissueToSamples <- list()
	ocLevels <- paste0("OncoTree", 1:4)
	
	for (sample in rownames(sampleData)){
		sampleOcTypes <- as.character(sampleData[sample, ocLevels])
		typeName <- sampleOcTypes[1]
		if (is.na(typeName)){
			next
		}
		
		tissueToSamples[[typeName]] <- c(tissueToSamples[[typeName]], sample)
		for (i in (2:4)){
			if (is.na(sampleOcTypes[i])){
				break
			}
			typeName <- paste0(typeName, typeLevelSeparator, sampleOcTypes[i])
			tissueToSamples[[typeName]] <- c(tissueToSamples[[typeName]], sample)
		}
	}
	
	# ----[test]------------------------------------------------------------------
	# 	stopifnot(identical(sort(unique(c(tissueToSamples, recursive = TRUE))),
	# 						sort(rownames(sampleData))))
	# 	for (typeName in names(tissueToSamples)){
	# 		ocTypes <- str_split(typeName, pattern = typeLevelSeparator)[[1]]
	#
	# 		for (sample in tissueToSamples[[typeName]]){
	# 			sampleOcTypes <- as.character(sampleData[sample, ocLevels])
	# 			stopifnot(identical(sampleOcTypes[1:length(ocTypes)], ocTypes))
	# 		}
	# 	}
	# ----------------------------------------------------------------------------
	
	return(tissueToSamples)
}


#' Title
#'
#' @param dataPkgName
#'
#' @return value
#'
#' @examples
#' NULL
loadSourceContent <- function(dataPkgName){
	if (!require(dataPkgName, character.only = TRUE)){
		stop(paste0("Package '", dataPkgName, "' is not available."))
	}
	srcEnv <- new.env()
	data("molData", package=dataPkgName, verbose=TRUE, envir=srcEnv)
	data("drugData", package=dataPkgName, verbose=TRUE, envir=srcEnv)
	
	src <- list()
	src$molPharmData <- getAllFeatureData(srcEnv$molData)
	src$molPharmData[["act"]] <- exprs(getAct(srcEnv$drugData))
	
	for (featureType in names(src$molPharmData)){
		rownames(src$molPharmData[[featureType]]) <-
			paste0(featureType, rownames(src$molPharmData[[featureType]]))
	}
	
	# TO DO: Update to obtain this information from featureData(getAct(srcEnv$drugData))
	src$drugInfo <- data.frame(ID = rownames(exprs(getAct(srcEnv$drugData))), stringsAsFactors = FALSE)
	src$drugInfo$NAME <- src$drugInfo$ID
	src$drugInfo$MOA <- character(nrow(src$drugInfo))
	
	stopifnot(identical(unname(removeMolDataType(rownames(src$molPharmData$act))),
											src$drugInfo$ID))
	rownames(src$drugInfo) <- rownames(src$molPharmData$act)
	
	src$sampleData <- getSampleData(srcEnv$molData)
	rownames(src$sampleData) <- src$sampleData$Name
	
	# TO DO: Check whether spaces in tissue sample names creates any problems.
	src$tissueToSamplesMap <- getTissueToSamplesMap(src$sampleData)
	
	# TO DO: Properly define color map.
	src$tissueColorMap <- rep("rgba(0,0,255,0.5)", length(src$tissueToSamplesMap))
	names(src$tissueColorMap) <- names(src$tissueToSamplesMap)
	
	return(src)
}

#--------------------------------------------------------------------------------------------------
# Helper functions.
#--------------------------------------------------------------------------------------------------

#' Title
#'
#' @param prefix
#' @param id
#' @param dataSource
#' @param srcContent
#'
#' @return value
#'
#' @examples
#' NULL
validateEntry <- function(prefix, id, dataSource, srcContent) {
	molPharmData <- srcContent[[dataSource]][["molPharmData"]]
	
	if(paste0(prefix, id) %in% rownames(molPharmData[[prefix]])) {
		return(TRUE)
	}
	
	return(FALSE)
}

#' Title
#'
#' @param prefix
#' @param id
#' @param dataSource
#' @param srcContent
#'
#' @return value
#'
#' @examples
#' NULL
getFeatureData <- function(prefix, id, dataSource, srcContent) {
	molPharmData <- srcContent[[dataSource]][["molPharmData"]]
	
	entry <- paste0(prefix, id)
	data <- as.numeric(molPharmData[[prefix]][entry, ])
	names(data) <- names(molPharmData[[prefix]][entry, ])
	
	results <- list(entry=entry, data=data)
	
	# e.g., expTOP1 with dataSource=nci60 becomes TOP1 (exp, nci60)
	results$plotLabel <- paste0(id, " (", prefix, ", ", dataSource, ")")
	
	# e.g., expTOP1 with dataSource=nci60 becomes expTOP1_nci60; needed for
	# getPlotData() results (data.frame) with data for same feature from different sources.
	results$uniqName <- paste0(results$entry, "_", dataSource)
	
	results$dataSource <- dataSource
	
	return(results)
}

#' Title
#'
#' @param xData
#' @param yData
#' @param showColor
#' @param showColorTissues
#' @param dataSource
#' @param srcContent
#'
#' @return value
#'
#' @examples
#' NULL
getPlotData <- function(xData, yData, showColor, showColorTissues, dataSource=NULL, srcContent){
	if (is.null(dataSource)){
		dataSource <- xData$dataSource
	}
	
	#-----[make sure x and y data cell lines are matched]----------------------------------
	if (xData$dataSource != yData$dataSource){
		if (require(rcellminerUtils)){
			matchedLinesTab <- getMatchedCellLines(c(xData$dataSource, yData$dataSource))
			xData$data <- xData$data[matchedLinesTab[, 1]]
			yData$data <- yData$data[matchedLinesTab[, 2]]
		} else{
			stop("Install rcellminerUtils package to find matched cell lines between different data sources.")
		}
	} else{
		stopifnot(identical(names(xData$data), names(yData$data)))
	}
	#--------------------------------------------------------------------------------------
	
	df <- data.frame(x=names(xData$data), y=xData$data, z=yData$data, stringsAsFactors = FALSE)
	rownames(df) <- df$x
	colnames(df) <- c("Cell Line", xData$uniqName, yData$uniqName)
	
	# HighCharts series name
	df$tissues <- srcContent[[dataSource]]$sampleData[rownames(df), "TissueType"]
	
	# HighCharts point name
	df$name <- srcContent[[dataSource]]$sampleData[rownames(df), "Name"]
	
	# HighCharts point x, y for scatter plot
	df$x <- df[,xData$uniqName]
	df$y <- df[,yData$uniqName]
	
	# NOTE: making assumption that tissue type sets are disjoint, which may not hold
	# once hierarchy of tissue types is introduced (OK, i.e., disjoint at OncoTree1 level).
	if(showColor) {
		if("all" %in% showColorTissues) {
			sampleTissueTypes <- srcContent[[dataSource]]$sampleData[rownames(df), "OncoTree1"]
			colorsToUse <- srcContent[[dataSource]]$tissueColorMap[sampleTissueTypes]
		} else {
			colorsToUse <- rep("rgba(0,0,255,0.5)", nrow(df)) #blue
			names(colorsToUse) <- rownames(df)
			
			for (tissueType in showColorTissues){
				matchedSamples <- intersect(srcContent[[dataSource]]$tissueToSamplesMap[[tissueType]],
																		rownames(df))
				colorsToUse[matchedSamples] <- "rgba(255,0,0,0.7)" # red
			}
		}
	} else{
		colorsToUse <- rep("rgba(0,0,255,0.5)", nrow(df)) #blue
	}
	
	df$color <- colorsToUse
	
	# Restrict to rows with no NAs in either column x or column y.
	notNaData <- (!is.na(df[, xData$uniqName])) & (!is.na(df[, yData$uniqName]))
	df <- df[notNaData, ]
	
	return(df)
}

#' Title
#'
#' @param xData
#' @param yData
#' @param showColor
#' @param showColorTissues
#' @param dataSource
#' @param srcContent
#'
#' @return value
#'
#' @examples
#' NULL
makePlotStatic <- function(xData, yData, showColor, showColorTissues, dataSource, srcContent) {
	df <- getPlotData(xData, yData, showColor, showColorTissues, dataSource, srcContent)
	
	corResults <-cor.test(df[,xData$uniqName], df[,yData$uniqName], use="pairwise.complete.obs")
	
	title <- paste0(paste(yData$plotLabel, '~', xData$plotLabel),
									', r=', round(corResults$estimate, 2),
									' p=', signif(corResults$p.value, 2))
	
	plot(df[, xData$uniqName], df[, yData$uniqName], xlab=xData$plotLabel, ylab=yData$plotLabel,
			 col=df[,"color"], pch=16, main=title)
	formula <- as.formula(paste(yData$uniqName, "~", xData$uniqName))
	abline(lm(formula, df), col="red")
}
#--------------------------------------------------------------------------------------------------