R/makedfMarkColor.R

In idiogramFISH: Shiny App. Idiograms with Marks and Karyotype Indices

#' Function to automatically make a data.frame of Marks' characterisitcs
#'
#' @description This function reads character vector with marks names
#' @description It returns a data.frame with color and style for each mark
#'
#' @param markNames names of marks
#' @param dfMarkColor d.f of marks to use
#' @param colorstoremove remove this colors from the result
#' @param defaultStyleMark character vector with default style \code{"square"}
#' \code{"cM"}
#' \code{"dots"}
#'
#' @keywords mark
#' @keywords internal
#' @return data.frame
#' @importFrom grDevices col2rgb

makedfMarkColor<- function(dfMarkColor,markNames,colorstoremove=NA
                           ,defaultStyleMark="square"
                           ,reserveDF
                           ) {

  message(crayon::green(paste("By default 5S are plotted as dots, to change this behavior make your own dfMarkColor data.frame") ) )

  tryCatch(dfMarkColor[which(dfMarkColor$style %in% "square"),]$style <- defaultStyleMark,error=function(e) "")

  manualcolors<-c('black','forestgreen', 'orange', 'cornflowerblue',
                    'magenta', 'darkolivegreen4',
                    'indianred1', 'tan4', 'darkblue', 'red2',
                    'mediumorchid1','firebrick4',  'yellowgreen', 'lightsalmon', 'tan3',
                    "tan1",'darkgray', 'wheat4', '#DDAD4B', 'chartreuse', 'seagreen1',
                    'moccasin', 'mediumvioletred', 'seagreen','cadetblue1',
                    "darkolivegreen1" ,"tan2" ,   "tomato3" , "#7CE3D8","gainsboro")

  manualcolors<-manualcolors[!manualcolors %in% colorstoremove]

  dfMarkColorNew <- data.frame(markName=markNames)

  dfMarkColorNew$markNameNP<- gsub("^inProtein","",dfMarkColorNew$markName)

  dfMarkColor$markNameNP<- gsub("^inProtein","",dfMarkColor$markName)

  dfMarkColorNew$markColor <- NA

  manualcolors <- manualcolors[!manualcolors %in% c(dfMarkColor$markColor)]

  dfMarkColorNew$markColor<-dfMarkColor$markColor[
    match(toupper(dfMarkColorNew$markNameNP),toupper(dfMarkColor$markNameNP) )]

  if("protruding" %in% colnames(dfMarkColor)){
  dfMarkColorNew$protruding <- dfMarkColor$protruding[
    match(toupper(dfMarkColorNew$markNameNP),toupper(dfMarkColor$markNameNP) )]
  }

  areNA<-which(is.na(dfMarkColorNew$markColor) )

  if(length(areNA)){
  dfMarkColorNew[areNA,]$markColor<- dfMarkColor$markColor[match(toupper(dfMarkColorNew[areNA,]$markNameNP),toupper(dfMarkColor$markName) )]
  }

  if(!missing(reserveDF)) {
  dfMarkColorNew$markColor2 <- reserveDF$markColor[match(toupper(dfMarkColorNew$markName)
                                                      ,toupper(paste0("inProtein",reserveDF$markName)  )
                                                      )]
  dfMarkColorNew[which(!is.na(dfMarkColorNew$markColor2)),]$markColor<-
    dfMarkColorNew[which(!is.na(dfMarkColorNew$markColor2)),]$markColor2

  }

  lenman <- length(dfMarkColorNew$markColor[which(is.na(dfMarkColorNew$markColor))])

  if(length(manualcolors) < lenman){
    message(crayon::blue(paste("Not enough colors, will be recycled - you can pass more colors with mycolors parameter") ) )
    repF<-ceiling(lenman/length(manualcolors) )
    manualcolors<-rep(manualcolors,repF)
  }

  dfMarkColorNew$markColor[which(is.na(dfMarkColorNew$markColor))] <- manualcolors[1:lenman]

  dfMarkColorNew$style <- dfMarkColor$style[match(toupper(dfMarkColorNew$markNameNP),toupper(dfMarkColor$markName) )]

  tryCatch(dfMarkColorNew[which(dfMarkColorNew$markName %in%
                         grep("inProtein",dfMarkColorNew$markName,value=TRUE) ),]$style<-"inProtein"
           ,error= function(e){""} )

  dfMarkColorNew$style[which(is.na(dfMarkColorNew$style))] <- defaultStyleMark
  dfMarkColorNew$markNameNP<-NULL
  return(dfMarkColorNew)
}