This repository has been archived by the owner on Oct 24, 2023. It is now read-only.
forked from Edouard-Legoupil/koboloadeR
/
utils2.R
137 lines (127 loc) · 2.42 KB
/
utils2.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
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
#' @name psum
#' @rdname psum
#' @title Sum with NA
#' @description Helper function that will sum values even if we have NA
#'
#' @param \dots List of integer or numeric
#' @param na.rm Bolean indicating if NA shall be removed
#'
#' @return Integer or numeric.
#'
#' @author Someone
#'
#' @examples
#' \dontrun{
#' psum()
#' }
#'
#' @export psum
#'
psum <- function(..., na.rm = FALSE) {
x <- list(...)
rowSums(matrix(unlist(x), ncol = length(x)), na.rm = na.rm)
}
#' @name round2
#' @rdname round2
#' @title Create roundup function
#'
#'
#' @param x List of integer or numeric to be rounded
#' @param n Rounding level
#'
#' @return rounded figure.
#'
#' @author Someone
#'
#' @examples
#' \dontrun{
#' round2(x, n)
#' }
#'
#' @export round2
#'
round2 = function(x, n) {
posneg = sign(x)
z = abs(x)*10^n
z = z + 0.5
z = trunc(z)
z = z/10^n
z*posneg
}
###
#' @name round_preserve_sum
#' @rdname round_preserve_sum
#' @title Helper function to round and preserve sum
#'
#' @param x = value
#' @param digits = digits
#'
#' @return value
#'
#' @author Someone http://biostatmatt.com/page/5
#'
#' @examples
#' \dontrun{
#' round_preserve_sum(x,digits)
#' }
#'
#' @export round_preserve_sum
#'
round_preserve_sum <- function(x, digits = 0) {
up <- 10 ^ digits
x <- x * up
y <- floor(x)
indices <- tail(order(x - y), round(sum(x)) - sum(y))
y[indices] <- y[indices] + 1
y / up
}
#' @name ltbl
#' @rdname ltbl
#' @title Helper function to extract the last part of question headings
#'
#' @param x = database name
#' @param y = column index group
#' @param z = column index
#'
#' @return last part of question headings
#'
#' @author Someone
#'
#' @examples
#' \dontrun{
#' ltbl(x,y,z)
#' }
#'
#' @export ltbl
#'
ltbl <- function(x,y,z){ gsub("\"","",tail(strsplit(names(x)[y][z],split = "/")[[1]],1))}
#' @name multresponse
#' @rdname multresponse
#' @title Helper function to concatenate multiple choices (select_mutiple type question) formatted TRUE / FALSE
#'
#'
#' @param x String
#' @return last part of question headings
#'
#' @author Someone
#'
#' @examples
#' \dontrun{
#' multresponse(x)
#' }
#'
#' @export multresponse
#'
multresponse <- function(x) {
y <- which(x == "TRUE")
if (length(y) != 0) {
for (tu in 1:length(y)) {
if (tu == 1) {
value <- ltbl(x,y[tu],1)
} else {
value <- c(value,ltbl(x,y[tu],1))
}
}
}else{value <- NA}
paste(value, collapse = " / ")
}