rossellhayes / fracture
1
#' Convert decimals to a character vector of fractions
2
#'
3
#' @inheritParams frac_mat
4
#' @param x A vector of decimals or, for `as.fracture()`, a matrix created by
5
#'   [frac_mat()]
6
#'
7
#' @return A character vector.
8
#' @seealso [frac_mat()] to return a matrix of numerators and denominators.
9
#' @export
10
#'
11
#' @example examples/fracture.R
12

13
fracture <- function(
14
  x, base_10 = FALSE, common_denom = FALSE, mixed = FALSE, max_denom = 1e7
15
) {
16 1
  op <- options(scipen = 100)
17 1
  on.exit(options(op), add = TRUE)
18

19 1
  matrix <- frac_mat(
20 1
    x            = x,
21 1
    base_10      = base_10,
22 1
    common_denom = common_denom,
23 1
    mixed        = mixed,
24 1
    max_denom    = max_denom
25
  )
26

27 1
  as.fracture(matrix)
28
}
29

30
#' @rdname fracture
31
#' @export
32

33
as.fracture <- function(x) {
34 1
  if (is.frac_mat(x)) {
35 1
    numeric  <- as.fracture_numeric(x)
36 1
    fracture <- as.fracture_paste(x)
37 1
    x        <- structure(fracture, numeric = numeric)
38 1
    class(x) <- c("fracture", "character")
39 1
    x
40
  } else {
41 1
    fracture(x)
42
  }
43
}
44

45
as.fracture_numeric <- function(x) {
46 1
  if (nrow(x) == 3) {
47 1
    numeric <- x[1, ] + x[2, ] / x[3, ]
48
  } else {
49 1
    numeric <- x[1, ] / x[2, ]
50
  }
51

52 1
  as.numeric(numeric)
53
}
54

55
as.fracture_paste <- function(x) {
56 1
  if (nrow(x) == 3) {
57 1
    x              <- rbind(x[1, ], " ", x[2, ], "/", x[3, ])
58 1
    no_frac        <- which(x[3, ] == 0)
59 1
    x[-1, no_frac] <- ""
60 1
    no_int         <- which(x[1, ] == 0)
61 1
    x[1:2, no_int] <- ""
62

63 1
    as.character(apply(x, 2, paste0, collapse = ""))
64
  } else {
65 1
    paste0(x[1, ], "/", x[2, ])
66
  }
67
}
68

69
#' @rdname fracture
70
#' @export
71

72
is.fracture <- function(x) {
73 1
  inherits(x, "fracture")
74
}
75

76
#' @export
77

78
as.character.fracture <- function(x, ...) {
79 1
  attr(x, "numeric") <- NULL
80 1
  class(x)           <- "character"
81 1
  x
82
}
83

84
#' @export
85

86
as.double.fracture <- function(x, ...) {
87 1
  attr(x, "numeric")
88
}
89

90
#' @export
91

92
as.integer.fracture <- function(x, ...) {
93 1
  x <- attr(x, "numeric")
94 1
  NextMethod()
95
}
96

97
#' @export
98

99
print.fracture <- function(x, ...) {
100 1
  x <- as.character(x)
101 1
  NextMethod("print", quote = FALSE)
102
}
103

104
#' @export
105

106
Math.fracture <- function(x, ...) {
107 1
  args <- recover_fracture_args(x)
108 1
  x    <- as.numeric(x)
109

110 1
  do.call("fracture", c(list(NextMethod()), args))
111
}
112

113
#' @export
114

115
Ops.fracture <- function(e1, e2) {
116 1
  is.numericish <- function(x) {
117 1
    is.numeric(x) | is.logical(x) | !is.null(attr(x, "numeric"))
118
  }
119

120 1
  if (is.numericish(e1) && is.numericish(e2)) {
121 1
    args <- recover_fracture_args(e1, e2)
122

123 1
    e1 <- as.numeric(e1)
124 1
    if (!missing(e2)) {e2 <- as.numeric(e2)}
125

126 1
    result <- NextMethod(.Generic)
127

128 1
    if (is.numeric(result)) {
129 1
      return(do.call("fracture", c(list(result), args)))
130
    } else {
131 1
      return(result)
132
    }
133
  }
134

135 1
  if (is.character(e1) && is.character(e2)) {return(NextMethod(.Generic))}
136

137 1
  if (is.fracture(e1)) {
138 1
    e1 <- attr(e1, "numeric")
139 1
    if (!is.null(e2)) {mode(e1) <- mode(e2)}
140 1
    return(NextMethod(.Generic))
141
  }
142

143 1
  if (is.fracture(e2)) {
144 1
    e2 <- attr(e2, "numeric")
145 1
    if (!is.null(e1)) {mode(e2) <- mode(e1)}
146 1
    return(NextMethod(.Generic))
147
  }
148
}
149

150
recover_fracture_args <- function(e1, e2 = NULL) {
151 1
  if (!is.fracture(e1) && !is.fracture(e2)) {
152 1
    return(NULL)
153
  }
154

155 1
  if (is.fracture(e1)) {
156 1
    e1 <- as.frac_mat(e1)
157 1
  } else if (is.numeric(e1)) {
158 1
    e1 <- frac_mat(e1, base_10 = TRUE, common_denom = TRUE)
159
  } else {
160 1
    e1 <- NULL
161
  }
162

163 1
  if (is.fracture(e2)) {
164 1
    e2 <- as.frac_mat(e2)
165 1
  } else if (is.numeric(e2)) {
166 1
    e2 <- frac_mat(e2, base_10 = TRUE, common_denom = TRUE)
167
  } else {
168 1
    e2 <- NULL
169
  }
170

171 1
  if (is.null(e1)) {e1 <- e2}
172 1
  if (is.null(e2)) {e2 <- e1}
173

174 1
  list(
175 1
    mixed        = nrow(e1) == 3 || nrow(e2) == 3,
176 1
    common_denom = length(unique(e1["denominator", ])) == 1 &&
177 1
      length(unique(e2["denominator", ])) == 1,
178 1
    base_10      = all(log(e1["denominator", ], 10) == 0) &&
179 1
      all(log(e2["denominator", ], 10) == 0)
180
  )
181
}

Read our documentation on viewing source code .

Loading