#' @name separate_to_groups_for_color
#' @rdname separate_to_groups_for_color
#' @title Seperate to groups for color
#' @author April/Frederik
#' @family grouping
#' @export
#Gradient for user upload color
separate_to_groups_for_color <- function(vp_data, color_data, color_theme, type){
# color_data <- color_data[complete.cases(color_data),]
# color_data <- as.numeric(color_data$score)
if(type == "cont"){
color_data$score_rounded <- round(as.numeric(color_data$score), 1)
col <- c(color = colorRampPalette(brewer.pal(11, color_theme))(((max(color_data$score_rounded)-min(color_data$score_rounded))*10 + 1)))
unique_col <- data.frame(cbind("unique_score"=seq(min(color_data$score_rounded), max(color_data$score_rounded), by=0.1), col))
color_d <- merge(unique_col, color_data, by.x = "unique_score", by.y = "score_rounded")
} else {
unique_score <- unique(sort(color_data$score))
col <- c(color = colorRampPalette(brewer.pal(3, color_theme))(length(unique_score)))
unique_col <- data.frame(cbind(unique_score, col))
color_d <- merge(unique_col, color_data, by.x = "unique_score", by.y = "score")
}
vp_data$score <- color_data$score[match(vp_data$gene, color_data$gene)]
vp_data$score[is.na(vp_data$score)] <- "empty"
yes_exist <- subset(vp_data, score != "empty")
no_exist <- subset(vp_data, score == "empty")
yes_exist$col <- color_d$col[match(yes_exist$gene, color_d$gene)]
df1 <- yes_exist
list(df1=df1, no_exist=no_exist)
}
#Discrete for user upload color
# separate_to_groups_for_color_discrete <- function(vp_data, color_data, color_theme, type){
# unique_score <- unique(sort(color_data$score))
# col <- c(color = colorRampPalette(brewer.pal(3, color_theme))(length(unique_score)))
# unique_col <- data.frame(cbind(unique_score, col))
# color_d <- merge(unique_col, color_data, by.x = "unique_score", by.y = "score")
#
# vp_data$score <- color_data$score[match(vp_data$gene, color_data$gene)]
# vp_data$score[is.na(vp_data$score)] <- "empty"
# yes_exist <- subset(vp_data, score != "empty")
# no_exist <- subset(vp_data, score == "empty")
#
# yes_exist$col <- color_d$col[match(yes_exist$gene, color_d$gene)]
# df1 <- yes_exist
#
# list(df1=df1, no_exist=no_exist)
# }
#' @rdname separate_to_groups_for_color
#Marker colors based on FDR
separate_to_groups_for_color_integrated <- function(vp_data, threshold, col1, col2){
below_thresh <- subset(vp_data, FDR < threshold)
above_thresh <- subset(vp_data, FDR >= threshold)
a_col <- colorRampPalette(c(col1, col1))(nrow(below_thresh))
below_thresh <- cbind(below_thresh, rev(a_col))
names(below_thresh)[names(below_thresh) == 'rev(a_col)'] <- 'col'
b_col <- colorRampPalette(c(col2, col2))(nrow(above_thresh))
above_thresh <- cbind(above_thresh, b_col)
names(above_thresh)[names(above_thresh) == 'b_col'] <- 'col'
data <- rbind(below_thresh, above_thresh)
}
# separate_to_groups_for_color_integrated <- function(vp_data, threshold){
# below_thresh <- subset(vp_data, FDR < threshold)
# above_thresh <- subset(vp_data, FDR >= threshold)
# below_thresh$col <- "sig"
# above_thresh$col <- "insig"
# # a_col <- colorRampPalette(c(col1, col1))(nrow(below_thresh))
# # below_thresh <- cbind(below_thresh, rev(a_col))
# # names(below_thresh)[names(below_thresh) == 'rev(a_col)'] <- 'col'
# # b_col <- colorRampPalette(c(col2, col2))(nrow(above_thresh))
# # above_thresh <- cbind(above_thresh, b_col)
# # names(above_thresh)[names(above_thresh) == 'b_col'] <- 'col'
# data <- rbind(below_thresh, above_thresh)
# }
#Blue and green separate, specifically in case plot opacity is low
# separate_to_groups_for_color_integrated_bar <- function(vp_data, threshold){
# below_thresh <- subset(vp_data, FDR <= threshold)
# above_thresh <- subset(vp_data, FDR > threshold)
# #
# a_col <- colorRampPalette(c('seagreen3', 'seagreen3'))(nrow(below_thresh))
# below_thresh <- cbind(below_thresh, rev(a_col))
# names(below_thresh)[names(below_thresh) == 'rev(a_col)'] <- 'col'
# b_col <- colorRampPalette(c("royalblue2", "royalblue2"))(nrow(above_thresh))
# above_thresh <- cbind(above_thresh, b_col)
# names(above_thresh)[names(above_thresh) == 'b_col'] <- 'col'
# data <- rbind(below_thresh, above_thresh)
# }
#' @rdname separate_to_groups_for_color
#Two gray tones
separate_to_groups_for_cbf_integrated <- function(vp_data, threshold){
below_thresh <- subset(vp_data, FDR < threshold)
above_thresh <- subset(vp_data, FDR >= threshold)
a_col <- colorRampPalette(c('#525252', '#525252'))(nrow(below_thresh))
below_thresh <- cbind(below_thresh, rev(a_col))
names(below_thresh)[names(below_thresh) == 'rev(a_col)'] <- 'col'
b_col <- colorRampPalette(c("grey76", "grey76"))(nrow(above_thresh))
above_thresh <- cbind(above_thresh, b_col)
names(above_thresh)[names(above_thresh) == 'b_col'] <- 'col'
data <- rbind(below_thresh, above_thresh)
}
#Two gray tones, specifically in case plot opacity is low
# separate_to_groups_for_cbf_integrated_bar <- function(vp_data, threshold){
# below_thresh <- subset(vp_data, FDR <= threshold)
# above_thresh <- subset(vp_data, FDR > threshold)
# a_col <- colorRampPalette(c('#969696', '#969696'))(nrow(below_thresh))
# below_thresh <- cbind(below_thresh, rev(a_col))
# names(below_thresh)[names(below_thresh) == 'rev(a_col)'] <- 'col'
# b_col <- colorRampPalette(c("#d9d9d9", "#d9d9d9"))(nrow(above_thresh))
# above_thresh <- cbind(above_thresh, b_col)
# names(above_thresh)[names(above_thresh) == 'b_col'] <- 'col'
# data <- rbind(below_thresh, above_thresh)
# }
#' @rdname separate_to_groups_for_color
separate_to_groups_for_exac_bar <- function(vp_data){
grp1 <- subset(vp_data, FDR <= 0.33)
grp2 <- subset(vp_data, 0.33 < FDR & FDR <= 0.66)
grp3 <- subset(vp_data, 0.66 < FDR & FDR <= 1)
a_col <- colorRampPalette(c('#66c2a5', '#66c2a5'))(nrow(grp1))
grp1 <- cbind(grp1, rev(a_col))
names(grp1)[names(grp1) == 'rev(a_col)'] <- 'col'
b_col <- colorRampPalette(c("#fc8d62", "#fc8d62"))(nrow(grp2))
grp2 <- cbind(grp2, b_col)
names(grp2)[names(grp2) == 'b_col'] <- 'col'
c_col <- colorRampPalette(c("#8da0cb", "#8da0cb"))(nrow(grp3))
grp3 <- cbind(grp3, c_col)
names(grp3)[names(grp3) == 'c_col'] <- 'col'
data <- rbind(grp1, grp2, grp3)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.