R/transformFCSbyCIPHE.R

In Selkie-13/Jarvis:

logiclTransformCIPHE <- function(flow.frame, value = NULL, marker = NULL){

  if(is.null(marker)){
    if(is.null(flow.frame@description[["SPILL"]])){
      markers.transform <- colnames(flow.frame)
    } else {
      markers.transform <- colnames(flow.frame@description[["SPILL"]])
    }
  } else {
    markers.transform <- marker
  }

  list.index <- names(unlist(lapply(markers.transform, function(x) return(which(flow.frame@description==x)))))
  list.index <- gsub("N","", list.index)
  list.index <- gsub("\\$P","", list.index)

  if(is.null(value) || is.na(value)){
    if(!is.null(flow.frame@description[[paste0("$P",list.index[1],"MS")]])){
      r.values <- unlist(lapply(list.index, function(x)
        as.integer(flow.frame@description[[paste0("$P",x,"MS")]]))
      )
    } else if(!is.null(flow.frame@description[[paste0("P",list.index[1],"MS")]])) {
      r.values <- unlist(lapply(list.index, function(x)
        as.integer(flow.frame@description[[paste0("P",x,"MS")]]))
      )
    } else {
      r.values <- rep(90, length(list.index))
    }
  }
  else {
    r.values <- rep(value, length(list.index))
  }

  w.values <- (4.5-log10(262143/abs(r.values)))/2
  w.values[which(w.values<0)] <- 0.5
  w.values[which(is.infinite(w.values))] <- 0.5

  for(t in 1:length(markers.transform)){
    lgcl <- flowCore::logicleTransform(w=w.values[t])
    flow.frame <- flowCore::transform(flow.frame, transformList(markers.transform[t],lgcl))
  }

  return(flow.frame)
}

inversLogiclTransformCIPHE <- function(flow.frame, value = NULL, marker = NULL){
  if(is.null(marker)){
    if(is.null(flow.frame@description[["SPILL"]])){
      markers.transform <- colnames(flow.frame)
    } else {
      markers.transform <- colnames(flow.frame@description[["SPILL"]])
    }
  } else {
    markers.transform <- marker
  }

  list.index <- names(unlist(lapply(markers.transform, function(x) return(which(flow.frame@description==x)))))
  list.index <- gsub("N","", list.index)
  list.index <- gsub("\\$P","", list.index)

  if(is.null(value) || is.na(value)){
    if(!is.null(flow.frame@description[[paste0("$P",list.index[1],"MS")]])) {
      r.values <- unlist(lapply(list.index, function(x)
        as.integer(flow.frame@description[[paste0("$P",x,"MS")]]))
      )
    } else if(!is.null(flow.frame@description[[paste0("P",list.index[1],"MS")]])) {
      r.values <- unlist(lapply(list.index, function(x)
        as.integer(flow.frame@description[[paste0("P",x,"MS")]]))
      )
    } else {
      r.values <- rep(90, length(list.index))
    }
  }
  else {
    r.values <- rep(value, length(list.index))
  }

  w.values <- (4.5-log10(262144/abs(r.values)))/2
  w.values[which(w.values<0)] <- 0.5
  w.values[which(is.infinite(w.values))] <- 0.5

  flow.frame.inv <- flow.frame

  for(t in 1:length(markers.transform)){
    invLgcl <- inverseLogicleTransform(trans = logicleTransform(w=w.values[t]))
    flow.frame.inv <- transform(flow.frame.inv, transformList(markers.transform[t],invLgcl))
  }

  return(flow.frame.inv)
}

arcsinhTransCIPHE <- function(flow.frame, marker=NULL, arg=5){
  raw <- flow.frame@exprs
  mat <- flow.frame@exprs
  if(is.null(marker) || length(marker)<1){
    marker <- colnames(flow.frame)
  }
  # print(marker)
  mat <- mat[,marker]
  colnames(mat) <- marker
  if(length(arg)==length(marker)){
    res <- lapply(c(1:length(marker)),function(x){
      col <- mat[,marker[x]]
      col <- asinh(col/arg[x])
      return(col)
    })
    mat <- do.call(cbind,res)
    colnames(mat) <- marker
  } else {
    mat <- asinh(mat/arg)
  }
  raw[,marker] <- mat[,marker]
  flow.frame@exprs <- raw
  return(flow.frame)
}

inversArcsinhTransCIPHE <- function(flow.frame, marker=NULL, arg=5){
  raw <- flow.frame@exprs
  mat <- flow.frame@exprs
  if(is.null(marker) || length(marker)<1){
    marker <- colnames(flow.frame)
  }
  # print(marker)
  mat <- mat[,marker]
  colnames(mat) <- marker
  if(length(arg)==length(marker)){
    res <- lapply(c(1:length(marker)),function(x){
      print(marker[x])
      col <- mat[,marker[x]]
      col <- sinh(col)*(arg[x])
      return(col)
    })
    mat <- do.call(cbind,res)
    colnames(mat) <- marker
  } else {
    mat <- sinh(mat)*arg
  }
  raw[,marker] <- mat[,marker]
  flow.frame@exprs <- raw
  return(flow.frame)
}