rsquaredacademy / descriptr
1
formatter_freq <- function(x) {
2 1
  return(format(as.character(x), width = 13, justify = "centre"))
3
}
4

5

6
formatter <- function(x) {
7 1
  return(format(as.character(x), width = 13, justify = "right"))
8
}
9

10
percent <- function(x, y) {
11 1
  out <- round((x / y) * 100, 2)
12 1
  return(out)
13
}
14

15

16
formata <- function(x, round, width, justify = "centre") {
17 1
  return(format(as.character(round(x, round)), width = width, justify = justify))
18
}
19

20
formatas <- function(x, round, width, justify = "centre") {
21 1
  return(format(x, width = width, justify = justify))
22
}
23

24
bin_size <- function(data, bins) {
25 1
  return((max(data, na.rm = TRUE) - min(data, na.rm = TRUE)) / bins)
26
}
27

28
intervals <- function(data, bins, na.rm = TRUE) {
29 1
  binsize <- bin_size(data, bins)
30 1
  bin <- bins - 1
31 1
  interval <- min(data)
32 1
  for (i in seq_len(bin)) {
33 1
    out <- interval[i] + binsize
34 1
    interval <- c(interval, out)
35
  }
36 1
  interval <- c(interval, max(data))
37 1
  return(interval)
38
}
39

40
freq <- function(data, bins, inta) {
41 1
  result <- c()
42 1
  for (i in seq_len(bins)) {
43 1
    k <- i + 1
44 1
    freq <- data >= inta[i] & data <= inta[k]
45 1
    out <- length(data[freq])
46 1
    result <- c(result, out)
47
  }
48 1
  return(result)
49
}
50

51
div_by <- function(x) {
52 1
  1 / x
53
}
54

55
standardize <- function(x, avg, stdev, p) {
56 1
  ((x - avg) / stdev) ^ p
57
}
58

59

60
sums <- function(x, q) {
61 1
  avg    <- mean(x)
62 1
  stdev  <- sd(x)
63 1
  result <- sum(sapply(x, standardize, avg, stdev, q))
64 1
  return(result)
65
}
66

67
md_helper <- function(x, y) {
68 1
  abs(x - y)
69
}
70

71
#' Standard error of mean
72
#'
73
#' Returns the standard error of mean.
74
#'
75
#' @param x A numeric vector.
76
#'
77
#' @examples
78
#' ds_std_error(mtcars$mpg)
79
#'
80
#' @export
81
#'
82
ds_std_error <- function(x) {
83 1
  sd(x) / (length(x) ^ 0.5)
84
}
85

86
uss <- function(x, y) {
87 1
  (x - y) ^ 2
88
}
89

90
stat_uss <- function(x) {
91 1
  sum(x ^ 2)
92
}
93

94

95
formatl <- function(x) {
96 1
  return(format(format(x, nsmall = 2), width = 20, justify = "left"))
97
}
98

99
formatol <- function(x, w) {
100 1
  format(as.character(x), width = w, justify = "centre")
101
}
102

103

104
formatr <- function(x, w) {
105 1
  format(rounda(x), nsmall = 2, width = w, justify = "right")
106
}
107

108

109
formatc <- function(x, w) {
110 1
  if (is.numeric(x)) {
111 1
    ret <- format(as.character(round(x, 2)), width = w, justify = "centre")
112
  } else {
113 1
    ret <- format(as.character(x), width = w, justify = "centre")
114
  }
115 1
  return(ret)
116
}
117

118

119
formatnc <- function(x, w) {
120 1
  format(format(round(x, 2), nsmall = 2), width = w, justify = "centre")
121
}
122

123

124
fs <- function() {
125 1
  x <- rep("  ")
126
}
127

128
formats <- function() {
129 1
  x <- rep("    ")
130
}
131

132
format_gap <- function(w) {
133 1
  x <- rep("", w)
134
}
135

136
return_pos <- function(data, number) {
137 1
  out <- c()
138 1
  for (i in seq_len(length(data))) {
139 1
    if (data[i] == number) {
140 1
      out <- c(out, i)
141
    }
142
  }
143 1
  return(out)
144
}
145

146
row_pct <- function(mat, tot) {
147 1
  rows <- dim(mat)[1]
148 1
  l <- length(tot)
149 1
  result <- c()
150 1
  for (i in seq_len(rows)) {
151 1
    diva <- mat[i, ] / tot[i]
152 1
    result <- rbind(result, diva)
153
  }
154 1
  rownames(result) <- NULL
155 1
  return(result)
156
}
157

158
col_pct <- function(mat, tot) {
159 1
  cols <- dim(mat)[2]
160 1
  l <- length(tot)
161 1
  result <- c()
162 1
  for (i in seq_len(cols)) {
163 1
    diva <- mat[, i] / tot[i]
164 1
    result <- cbind(result, diva)
165
  }
166 1
  colnames(result) <- NULL
167 1
  return(result)
168
}
169

170
rounda <- function(x) {
171 1
  round(x, 2)
172
}
173

174
l <- function(x) {
175 1
  x <- as.character(x)
176 1
  k <- grep("\\$", x)
177 1
  if (length(k) == 1) {
178 1
    temp <- strsplit(x, "\\$")
179 1
    out <- temp[[1]][2]
180
  } else {
181 1
    out <- x
182
  }
183 1
  return(out)
184
}
185

186
fround <- function(x) {
187 1
  format(round(x, 2), nsmall = 2)
188
}
189

190
seqlp <- function(mean, sd, el) {
191 1
  if (el > 4) {
192 1
    lmin <- mean - (el * sd)
193 1
    lmax <- mean + (el * sd)
194
  } else {
195 1
    lmin <- mean - (4 * sd)
196 1
    lmax <- mean + (4 * sd)
197
  }
198

199 1
  seq(lmin, lmax, sd)
200
}
201

202

203
xmmp <- function(mean, sd, el) {
204 1
  if (el > 4) {
205 1
    xmin <- mean - (el * sd)
206 1
    xmax <- mean + (el * sd)
207
  } else {
208 1
    xmin <- mean - (4 * sd)
209 1
    xmax <- mean + (4 * sd)
210
  }
211

212 1
  c(xmin, xmax)
213
}
214

215
seql <- function(mean, sd) {
216 1
  lmin <- mean - (5 * sd)
217 1
  lmax <- mean + (5 * sd)
218 1
  seq(lmin, lmax, sd)
219
}
220

221
xmm <- function(mean, sd) {
222 1
  xmin <- mean - (5 * sd)
223 1
  xmax <- mean + (5 * sd)
224 1
  c(xmin, xmax)
225
}
226

227

228
seqln <- function(mean, sd) {
229 1
  lmin <- mean - 3 * sd
230 1
  lmax <- mean + 3 * sd
231 1
  seq(lmin, lmax, sd)
232
}
233

234

235
xmn <- function(mean, sd) {
236 1
  xmin <- mean - 3 * sd
237 1
  xmax <- mean + 3 * sd
238 1
  c(xmin, xmax)
239
}
240

241
trimmed_mean <- function(x, na.rm = FALSE) {
242 1
  if (na.rm) {
243 0
    x <- na.omit(x)
244
  }
245 1
  mean(x, trim = 0.05)
246
}
247

248
quant1 <- function(x, na.rm = FALSE) {
249 1
  if (na.rm) {
250 0
    x <- na.omit(x)
251
  }
252 1
  quantile(x, probs = 0.25)
253
}
254

255
quant3 <- function(x, na.rm = FALSE) {
256 1
  if (na.rm) {
257 0
    x <- na.omit(x)
258
  }
259 1
  quantile(x, probs = 0.75)
260
}
261

262
string_to_name <- function(x, index = 1) {
263 1
  rlang::sym(x$utility$varnames[index])
264
}
265

266
#' @importFrom utils packageVersion menu install.packages globalVariables
267
check_suggests <- function(pkg) {
268

269 0
  pkg_flag <- tryCatch(packageVersion(pkg), error = function(e) NA)
270

271 0
  if (is.na(pkg_flag)) {
272

273 0
    msg <- message(paste0('\n', pkg, ' must be installed for this functionality.'))
274

275 0
    if (interactive()) {
276 0
      message(msg, "\nWould you like to install it?")
277 0
      if (menu(c("Yes", "No")) == 1) {
278 0
        install.packages(pkg)
279
      } else {
280 0
        stop(msg, call. = FALSE)
281
      }
282
    } else {
283 0
      stop(msg, call. = FALSE)
284
    }
285
  }
286

287
}
288

289
check_df <- function(data) {
290 1
  data_name <- deparse(substitute(data))
291 1
  if (!is.data.frame(data)) {
292 1
    stop(paste0(data_name, ' must be a `data.frame` or `tibble`.'), call. = FALSE)
293
  }
294
}
295

296
check_numeric <- function(data, var, var_name) {
297

298 1
  vary      <- rlang::enquo(var)
299 1
  ndata     <- dplyr::pull(data, !! vary)
300 1
  var_class <- class(ndata)
301

302 1
  msg <- paste0(var_name, ' is not a continuous variable. The function expects an object of type `numeric` or `integer` but ', var_name, ' is of type `', var_class, '`.')
303 1
  if (!is.numeric(ndata)) {
304 1
    stop(msg, call. = FALSE)
305
  }
306
}
307

308
check_factor <- function(data, var, var_name) {
309

310 1
  vary      <- rlang::enquo(var)
311 1
  fdata     <- dplyr::pull(data, !! vary)
312 1
  var_class <- class(fdata)
313

314 1
  msg <- paste0(var_name, ' is not a categorical variable. The function expects an object of type `factor` but ', var_name, ' is of type `', var_class, '`.')
315 1
  if (!is.factor(fdata)) {
316 1
    stop(msg, call. = FALSE)
317
  }
318
}
319

320
ds_rule <- function(text = NULL) {
321 1
  con_wid  <- options()$width
322 1
  text_len <- nchar(text) + 2
323 1
  dash_len <- (con_wid - text_len) / 2
324 1
  cat(paste(rep("-", dash_len)), ' ', text, ' ',
325 1
      paste(rep("-", dash_len)), sep = "")
326
}
327

328
ds_num_cols <- function(data) {
329 1
  is_num <- sapply(data, is.numeric)
330 1
  if (!any(is_num)) {
331 1
    stop("Data has no continuous variables.", call. = FALSE)
332
  }
333 1
  data[is_num]
334
}
335

336
ds_loc_prep <- function(data, vars = NULL, trim = 0.05, decimals = 2) {
337

338 1
  if (is.null(vars)) {
339 1
    varyable <- names(data)
340
  } else {
341 1
    varyable <- vars
342
  }
343

344 1
  measure <- data.frame(variable  = varyable,
345 1
                        n         = sapply(data, length),
346 1
                        missing   = sapply(data, function(x) sum(is.na(x))),
347 1
                        mean      = round(sapply(data, mean, na.rm = TRUE), decimals),
348 1
                        trim_mean = round(sapply(data, mean, trim, na.rm = TRUE), decimals),
349 1
                        median    = round(sapply(data, median, na.rm = TRUE), decimals),
350 1
                        mode      = round(sapply(data, ds_mode), decimals))
351

352 1
  result <- measure[order(measure$variable), ]
353 1
  rownames(result) <- NULL
354 1
  return(result)
355
}

Read our documentation on viewing source code .

Loading