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 .