-
Notifications
You must be signed in to change notification settings - Fork 0
/
zlog.R
91 lines (76 loc) · 2.94 KB
/
zlog.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
###################################################################################################
######################### Script to compute the zlog value ########################################
###################################################################################################
#' Computes the zlog value of x given the lower und upper reference limits L and U
#'
#' @param x value
#' @param L lower reference limit
#' @param U upper reference limit
zlog <- function(x,L=0,U=0){
if (is.na(x) | is.na(L) | is.na(U) | L<=0 | U<=0 | U<=L){
return(NA)
}
logl <- log(L)
logu <- log(U)
mu.log <- (logl+logu)/2
sigma.log <- (logu - logl)/(3.919928)
return((log(x)-mu.log)/sigma.log)
}
#' Round numeric values from a dataframe
#'
#' @param x Expects dataframe
#' @param digits Digits to round
round_df <- function(x, digits) {
numeric_columns <- sapply(x, mode) == 'numeric'
x[numeric_columns] <- round(x[numeric_columns], digits)
return(x)
}
#' Get the colors to the zlog values
#'
#' Returns a color between blue via white to red (HEX or RGB)
#'
#' @param x Expects a (zlog) value x
zlogcolor <- function(x, hex = TRUE,
a = c(0, 20), w = c(255, 235), t = c(4, 4),
s = c(1.5, 1.5), m = c(-4, -6)){
R = round(a[1] + w[1] / ((1 + t[1] * exp(-s[1] * ( x - m[1]))) ^ (1 / t[1])))
B = round(a[1] + w[1] / ((1 + t[1] * exp(-s[1] * (-x - m[1]))) ^ (1 / t[1])))
G = sapply(x, function(x) ifelse(x < 0,
round(a[2] + w[2] / ((1 + t[2] * exp(-s[2] * ( x - m[2]))) ^ (1 / t[2]))),
round(a[2] + w[2] / ((1 + t[2] * exp(-s[2] * (-x - m[2]))) ^ (1 / t[2])))))
# if(x < 0) {
# G = round(a[2] + w[2] / ((1 + t[2] * exp(-s[2] * ( x - m[2]))) ^ (1 / t[2])))
# } else {
# G = round(a[2] + w[2] / ((1 + t[2] * exp(-s[2] * (-x - m[2]))) ^ (1 / t[2])))
# }
R[is.na(R)] <- 255
B[is.na(B)] <- 255
G[is.na(G)] <- 255
ifelse (hex,
return(rgb(R, G, B, max = 255)),
return(c(R, G, B)))
}
#' Get the zlog value and check if the background is to dark and change the textcolor to white
#'
#' Returns a color between blue via white to red (HEX or RGB)
#'
#' @param x Expects a (zlog) value x
#' @param threshold Given threshold for the zlog value
#' @param background Variable to decide id the color affects the background or the text
highzlogvalues <- function(x, hex = TRUE, threshold = 8, background = FALSE){
if(!background){
G = sapply(x, function(x) ifelse(x < -threshold, 255, 0))
R = sapply(x, function(x) ifelse(x < -threshold, 255, 0))
B = sapply(x, function(x) ifelse(x < -threshold, 255, 0))
} else{
G = sapply(x, function(x) ifelse(x > threshold, 192, 255))
R = sapply(x, function(x) ifelse(x > threshold, 192, 255))
B = sapply(x, function(x) ifelse(x > threshold, 192, 255))
}
R[is.na(R)] <- 0
B[is.na(B)] <- 0
G[is.na(G)] <- 0
ifelse (hex,
return(rgb(R, G, B, max = 255)),
return(c(R, G, B)))
}