├── .Rbuildignore ├── .gitignore ├── DESCRIPTION ├── LICENSE ├── LICENSE.md ├── NAMESPACE ├── NOTES.md ├── R ├── call.R ├── coef.R ├── fit.R ├── model-mlm.R ├── print.R ├── tidy.R ├── utils-fit.R ├── utils.R └── zzz.R ├── README.Rmd ├── README.md ├── data └── polcom.rda ├── logo.R ├── make.R ├── man ├── as_tbl.Rd ├── figures │ └── logo.png ├── nagelkerke.Rd ├── pipe.Rd ├── tbl_frame.Rd └── tidy_mlm.Rd └── tidymlm.Rproj /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | ^logo\.R$ 4 | ^make\.R$ 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rhistory 2 | .RData 3 | .Rproj.user 4 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: tidymlm 2 | Version: 0.0.1 3 | Title: Tidy Multilevel Model Tools for Academics 4 | Description: Tidy tools designed for use in multilevel modeling used for 5 | academic research. This package uses tidy evaluation (a form of 6 | non-standard evaluation) for ease of use and helps researchers keep their 7 | data and analysis tidy. 8 | Encoding: UTF-8 9 | LazyData: true 10 | ByteCompile: true 11 | Author: person("Michael Wayne", "Kearney", , 12 | "kearneymw@missouri.edu", role = c("aut", "cre"), 13 | comment = c(ORCID = "0000-0002-0730-4694")) 14 | License: MIT + file LICENSE 15 | RoxygenNote: 6.0.1.9000 16 | Imports: 17 | broom, 18 | lme4, 19 | magrittr, 20 | rlang, 21 | robustlmm, 22 | tibble, 23 | tidyselect 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2018 2 | COPYRIGHT HOLDER: Michael Wayne Kearney 3 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2018 Michael Wayne Kearney 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(coerce_numeric,character) 4 | S3method(coerce_numeric,default) 5 | S3method(nagelkerke,default) 6 | S3method(print,tidy_model) 7 | export("%>%") 8 | export(as_tbl) 9 | export(coerce_numeric) 10 | export(nagelkerke) 11 | export(tbl_frame) 12 | export(tidy_mlm) 13 | export(tidy_summary) 14 | importFrom(magrittr,"%>%") 15 | -------------------------------------------------------------------------------- /NOTES.md: -------------------------------------------------------------------------------- 1 | # NOTES 2 | 3 | ## Models 4 | + Multilevel models (lme4) 5 | - Random intercept 6 | - Random slope 7 | - Generalized mlm? 8 | + Strutural equation modeling (lavaan) 9 | - Multi-group models 10 | - CFA 11 | - Model comparisons 12 | - Indirect effects 13 | - Ordered vars 14 | + Path analysis 15 | - Wrapper around lavaan w/ observed vars 16 | - PROCESS-like features 17 | 18 | 19 | -------------------------------------------------------------------------------- /R/call.R: -------------------------------------------------------------------------------- 1 | 2 | type_mlm <- function(expr) { 3 | grepl("^rlmer$|^robustlmm::rlmer$|^lmer$|^lme4::lmer$", rlang::expr_text(expr[[1]])) 4 | } 5 | 6 | store_tidycall <- function(dims, expr) { 7 | ## initalize output list 8 | lst <- list() 9 | ## data dimensions 10 | if (is.numeric(dims)) { 11 | lst$data <- as.character(dims) 12 | } else if (is.data.frame(dims)) { 13 | lst$data <- dim(dims) 14 | } else { 15 | lst$data <- dim(model.frame(dims)) 16 | } 17 | ## store model from expr 18 | model <- expr[[2]] 19 | ## store model formula as character 20 | if (rlang::is_character(model)) { 21 | model <- strsplit(model, "\\n")[[1]] 22 | if (length(model) > 1L) { 23 | model <- paste(c(model[1], 24 | paste0(" ", model[-1])), 25 | collapse = "\n") 26 | } 27 | } else { 28 | model <- rlang::expr_text(model) 29 | } 30 | lst$model <- model 31 | ## type of model 32 | ## extract type from expr 33 | lst$type <- "mlm" 34 | ## whether the model is robust 35 | if (is_robust(expr)) { 36 | lst$robust <- TRUE 37 | } else { 38 | lst$robust <- FALSE 39 | } 40 | ## convert expr to pkg::fun 41 | lst$pkgfun <- pkgfun(expr) 42 | ## return as class tidycall 43 | structure(lst, class = "tidycall") 44 | } 45 | 46 | meta_call <- function() { 47 | fun <- c( "lm", "rlm", "aov", "glm", "glmRob", "glm", "glmRob", "glm", "glmRob", "sem", "sem", "lmer", "rlmm") 48 | type <- c( "ols", "ols", NA, "log", "log", "pois", "pois", "negbin", "negbin", NA, NA, NA, NA) 49 | robust <- c( FALSE, TRUE, FALSE, FALSE, TRUE, FALSE, TRUE, FALSE, TRUE, FALSE, TRUE, FALSE, TRUE) 50 | pkg <- c("stats", "MASS", "stats", "stats", "robust", "stats", "robust", "stats", "robust", "lavaan", "lavaan", "lme4", "robustlmm") 51 | tbl_frame(pkg, fun, robust, type) 52 | } 53 | 54 | 55 | 56 | pkg_models <- function(fun = NULL, type = NULL, robust = NULL, pkg = NULL) { 57 | mc <- meta_call() 58 | } 59 | 60 | print.tidycall <- function(x) { 61 | ## format model type 62 | if (is.null(x$type)) { 63 | type <- "" 64 | } else { 65 | type <- x$type 66 | } 67 | type <- "Multilevel Model (MLM)" 68 | ## format robust (if applicable) 69 | if (type != "" && x$robust) { 70 | type <- paste0("[Robust] ", type) 71 | } 72 | ## format data dimensions print out 73 | if (length(x$data) == 2) { 74 | data <- paste0(x$data[1], " (observations) X ", x$data[2], " (variables)") 75 | } else { 76 | data <- paste0(x$data, " (observations)") 77 | } 78 | p <- paste0("# A tidy model", 79 | "\nModel formula : ", x$model, 80 | "\nModel type : ", type, 81 | "\nModel pkg::fun : ", paste0(x$pkgfun, "()"), 82 | "\nModel data : ", data, "\n") 83 | cat(p, fill = TRUE) 84 | } 85 | 86 | get_tidycall <- function(m) { 87 | attr(m, "tidycall") 88 | } 89 | 90 | 91 | 92 | 93 | ## get package of first function for a given expression 94 | pkgfun <- function(expr) { 95 | ## validate input 96 | stopifnot(rlang::is_expression(expr)) 97 | ## convert function to text 98 | expr <- rlang::expr_text(expr[[1]]) 99 | ## if namespace already attached, return it otherwise look it up 100 | if (!grepl("\\:\\:", expr)) { 101 | ## lookup and return name of namespace 102 | #pkg <- rlang::env_name(rlang::fn_env(rlang::as_function(expr))) 103 | pkg <- rlang::ns_env_name(rlang::fn_env(rlang::as_function(expr))) 104 | ## remove "namespace:", only use pkg name 105 | pkg <- gsub(".*:", "", pkg) 106 | ## combine with namespace 107 | expr <- paste0(pkg, "::", expr) 108 | } 109 | expr 110 | } 111 | -------------------------------------------------------------------------------- /R/coef.R: -------------------------------------------------------------------------------- 1 | coef_default <- function(x) { 2 | ## broom the coef table, rename, and add stars column 3 | d <- tibble::as_tibble(broom::tidy(x), validate = FALSE) 4 | names(d)[2:4] <- c("est", "s.e.", "est.se") 5 | d <- add_stars(d) 6 | ## estimate/add standardized solution estimates and return 7 | add_std_est(d) 8 | } 9 | 10 | 11 | -------------------------------------------------------------------------------- /R/fit.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | fit_lm <- function(m) { 4 | if (inherits(m, "aov")) { 5 | s <- summary.lm(m) 6 | } else { 7 | s <- summary(m) 8 | } 9 | ## f and its p value 10 | f <- s$fstatistic[1] 11 | fp <- do.call("pf", as.list(c(unname(s$fstatistic), lower.tail = FALSE))) 12 | ## root mean square error 13 | rmse <- rmse(m) 14 | ## deviance 15 | #ll <- -2 * logLik(m) 16 | #lln <- as.integer(attr(ll, "df") 17 | # AIC/BIC 18 | aic <- AIC(m) 19 | bic <- BIC(m) 20 | ## stat name and estimate 21 | fit_statistic <- c("F", "R^2", "Adj R^2", "RMSE", "AIC", "BIC") 22 | estimate <- c(f, s$r.squared, s$adj.r.squared, rmse, aic, bic) 23 | ## degrees of freedom 24 | df <- rep(NA_integer_, length(fit_statistic)) 25 | df[match(fit_statistic[c(1)], fit_statistic)] <- c(as.integer(s$fstatistic[2])) 26 | n <- nobs(m) 27 | ## p values 28 | p.value <- rep(NA_real_, length(fit_statistic)) 29 | p.value[match(c("F"), fit_statistic)] <- fp 30 | ## stars 31 | stars <- make_stars(p.value) 32 | ## return data frame 33 | tibble::data_frame(fit_stat = fit_statistic, n, df, 34 | estimate, p.value, stars) 35 | } 36 | 37 | fit_glm <- function(m) { 38 | s <- summary(m) 39 | devn <- s$df.residual 40 | devp <- pchisq(s$deviance, devn, lower.tail = FALSE) 41 | nulln <- s$df.null 42 | nullp <- pchisq(s$null.deviance, nulln, lower.tail = FALSE) 43 | chisq <- s$null.deviance - s$deviance 44 | chisqn <- nulln - devn 45 | chisqp <- pchisq(chisq, chisqn, lower.tail = FALSE) 46 | aic <- AIC(m) 47 | bic <- BIC(m) 48 | rmse <- rmse(m) 49 | r2nag <- nagelkerke(m) 50 | #r2cox <- coxsnell(m) 51 | r2mcf <- mcfadden(m) 52 | ##mcfadden.adj(m) 53 | ## names of fit statistics 54 | fit_statistic <- c("χ2","Δχ2", "Nagelkerke R^2", 55 | "McFadden R^2", "RMSE", "AIC", "BIC") 56 | ## estimates 57 | estimate <- c(s$deviance, chisq, r2nag, r2mcf, rmse, aic, bic) 58 | ## degrees of freedom 59 | df <- rep(NA_integer_, length(fit_statistic)) 60 | df[match(fit_statistic[1:2], fit_statistic)] <- c(devn, chisqn) 61 | ## p values 62 | p.value <- rep(NA_real_, length(fit_statistic)) 63 | p.value[match(fit_statistic[1:2], fit_statistic)] <- c(devp, chisqp) 64 | ## number of obs 65 | n <- nobs(m) 66 | ## stars 67 | stars <- make_stars(p.value) 68 | ## return data frame 69 | tibble::data_frame(fit_stat = fit_statistic, n, df, 70 | estimate, p.value, stars) 71 | } 72 | 73 | -------------------------------------------------------------------------------- /R/model-mlm.R: -------------------------------------------------------------------------------- 1 | 2 | #' Multilevel model 3 | #' 4 | #' Conduct multilevel model analysis (AKA mixed models) 5 | #' 6 | #' @param data Data frame containing variables in model 7 | #' @param ... Model formula to be estimated 8 | #' @param robust Logial indicating whether to use a robust estimator 9 | #' @return A model object 10 | #' @export 11 | tidy_mlm <- function(.data, model, robust = FALSE, ...) { 12 | ## if robust, use rlmm pkg 13 | if (robust) { 14 | dots <- list(...) 15 | if ("REML" %in% names(dots) && !isTRUE(dots$REML)) { 16 | stop("`REML = FALSE` with robust linear mixed models", call. = FALSE) 17 | } 18 | ## store expression 19 | e <- rlang::expr(robustlmm::rlmer(!!model, data = .data, ...)) 20 | } else { 21 | ## store expression 22 | e <- rlang::expr(lme4::lmer(!!model, data = .data, ...)) 23 | } 24 | ## estimate model 25 | m <- eval(e) 26 | ## store info as tidycall attribute 27 | attr(m, "tidycall") <- store_tidycall(dim(m@frame), e) 28 | ## return model object 29 | m 30 | } 31 | 32 | -------------------------------------------------------------------------------- /R/print.R: -------------------------------------------------------------------------------- 1 | #' @export 2 | print.tidy_model <- function(x, ...) { 3 | ## space, label, and print fit 4 | cat("$fit", fill = TRUE) 5 | print_no_tibble(x$fit) 6 | ## space, label, and print coef 7 | cat("\n$coef", fill = TRUE) 8 | print_no_tibble(x$coef) 9 | } 10 | 11 | 12 | print_no_tibble <- function(x, n = NULL, 13 | dims = FALSE, 14 | class = FALSE, 15 | row.names = FALSE, 16 | leading_zero = TRUE) { 17 | x <- no_tibble(x, n, dims, class, row.names, leading_zero) 18 | cat(paste(x, collapse = "\n"), fill = TRUE) 19 | } 20 | 21 | trim_ws <- function(x) { 22 | gsub("^\\s+|\\s+$", "", x) 23 | } 24 | 25 | format_ncol <- function(x, nm) { 26 | ## 3 places past decimal 27 | x <- sprintf("%.3f ", x) 28 | ## replace NA with blanks 29 | x[grepl("^\\s{0,}NA\\s{0,}$", x)] <- "-----" ##"- " 30 | ## trim white space and calc characters 31 | chars <- nchar(trim_ws(x)) 32 | ## max char to determine spacing 33 | mchars <- max(c(chars, nchar(nm)), na.rm = TRUE) 34 | ## function to create string of spaces 35 | spaces <- function(n) paste(rep(" ", n), collapse = "") 36 | ## use diff bw chars and max for number of spaces 37 | sp <- sapply(mchars - chars, spaces) 38 | ## map paste0 to add spaces before value 39 | x <- unlist(Map(paste0, sp, x, USE.NAMES = FALSE)) 40 | x <- gsub("-----", " - ", x) 41 | ## estimate mid-point of string 42 | #m <- floor(mchars / 2) 43 | ## add dash to middle of completely blank lines (and remove a space) 44 | #x <- sub(sprintf("(?<=\\s{%d}).(?=\\s)", m, m), "-", x, perl = TRUE) 45 | x 46 | } 47 | 48 | format_icol <- function(x, nm) { 49 | m <- max(c(nchar(x), nchar(nm)), na.rm = TRUE) 50 | if (m < 4) { 51 | m <- 4 52 | } 53 | x <- sprintf(paste0("%", m, "g"), x) 54 | ## replace NA with blanks 55 | x[grepl("^\\s{0,}NA\\s{0,}$", x)] <- paste0( 56 | paste(rep(" ", m - 1), collapse = ""), "-") 57 | ## trim white space and calc characters 58 | x 59 | } 60 | 61 | format_col_nm <- function(x, nm) { 62 | m <- max(nchar(c(x, nm)), na.rm = TRUE) 63 | if (m < 4) { 64 | m <- 4 65 | } 66 | if (nchar(nm) < m) { 67 | n <- m - nchar(nm) 68 | nm <- paste0(paste(rep(" ", n), collapse = ""), nm) 69 | } 70 | nm 71 | } 72 | 73 | no_tibble <- function(x, n = NULL, 74 | dims = FALSE, 75 | class = FALSE, 76 | row.names = FALSE, 77 | leading_zero = TRUE) { 78 | if (all(c("est", "est.se") %in% names(x))) { 79 | coef <- TRUE 80 | } else { 81 | coef <- FALSE 82 | } 83 | if ("stars" %in% names(x)) { 84 | x$stars[x$stars == ""] <- "---" 85 | } 86 | ## format numeric columns 87 | is_num <- vapply(x, inherits, "numeric", FUN.VALUE = logical(1)) 88 | x[is_num] <- Map(format_ncol, x[is_num], names(x)[is_num]) 89 | ## format int columns 90 | is_int <- vapply(x, inherits, "integer", FUN.VALUE = logical(1)) 91 | x[is_int] <- Map(format_icol, x[is_int], names(x)[is_int]) 92 | ## fix names 93 | nmn <- sapply(x, function(x) max(nchar(x), na.rm = TRUE)) 94 | names(x)[is_num] <- unlist(Map(format_col_nm, x[is_num], names(x)[is_num])) 95 | names(x)[is_int] <- unlist(Map(format_col_nm, x[is_int], names(x)[is_int])) 96 | ## count obs 97 | nobs <- nrow(x) 98 | ## set n to obs if null 99 | if (is.null(n)) { 100 | n <- nobs 101 | } 102 | ## capture as text string 103 | x <- capture.output(print(x, n = n)) 104 | ## show column class 105 | if (!class) { 106 | x <- x[-3] 107 | } 108 | ## strip dimensions (A tibble...) line 109 | if (!dims) { 110 | x <- x[-1] 111 | } 112 | if (!row.names) { 113 | ## remove row names 114 | x[-1] <- sub(sprintf("^.{%d}", nchar(nobs) + 1), "", x[-1]) 115 | x[1] <- sub(sprintf("^\\s{0,%d}", nchar(nobs) + 1), "", x[1]) 116 | } 117 | ## replace quotes with blanks 118 | x <- gsub('"', " ", x) 119 | ## replace ticks with blanks 120 | x <- gsub("`", " ", x) 121 | ## replace 0.000 with <.001 122 | x <- gsub("0\\.000", "<.001", x) 123 | ## remove leading zeroes 124 | if (!leading_zero) { 125 | x <- gsub(" 0\\.", " .", x) 126 | x <- gsub(" -0\\.", " .", x) 127 | } 128 | ## trim white space from right end 129 | x <- sub("\\s+$", "", x) 130 | ## fix stars place holder 131 | x <- gsub("---", " ", x) 132 | ## realign names 133 | while (max(nchar(x[-1]), na.rm = TRUE) > nchar(x[1])) { 134 | x[1] <- sub("\\s(?=\\s)", "", x[1], perl = TRUE) 135 | } 136 | ## fix heading spacing for coef data 137 | if (coef) { 138 | x[1] <- sub("\\sest", "est", x[1]) 139 | } 140 | ## return 141 | x 142 | } 143 | -------------------------------------------------------------------------------- /R/tidy.R: -------------------------------------------------------------------------------- 1 | 2 | #' @export 3 | tidy_summary <- function(m) { 4 | print(get_tidycall(m)) 5 | tidy_model(m) 6 | } 7 | 8 | tidy_model <- function(m) { 9 | new_tidy_model( 10 | fit = model_fit(m), 11 | coef = model_coef(m), 12 | data = model_data(m) 13 | ) 14 | } 15 | 16 | new_tidy_model <- function(fit, coef, data) { 17 | stopifnot(is.data.frame(fit)) 18 | stopifnot(is.data.frame(coef)) 19 | if (!is.data.frame(data)) { 20 | data <- tbl_frame() 21 | } 22 | structure( 23 | list( 24 | fit = fit, 25 | coef = coef, 26 | data = data 27 | ), 28 | class = "tidy_model" 29 | ) 30 | } 31 | 32 | 33 | 34 | ##----------------------------------------------------------------------------## 35 | ## MODEL COEF ## 36 | ##----------------------------------------------------------------------------## 37 | 38 | model_coef <- function(x) UseMethod("model_coef") 39 | 40 | model_coef.default <- function(x) coef_default(x) 41 | 42 | 43 | ##----------------------------------------------------------------------------## 44 | ## MODEL FIT ## 45 | ##----------------------------------------------------------------------------## 46 | 47 | model_fit <- function(x) UseMethod("model_fit") 48 | 49 | model_fit.lm <- function(x) fit_lm(x) 50 | 51 | ##----------------------------------------------------------------------------## 52 | ## MODEL DATA ## 53 | ##----------------------------------------------------------------------------## 54 | 55 | model_data <- function(x) UseMethod("model_data") 56 | 57 | model_data.default <- function(x) { 58 | x <- tryCatch(broom::augment(x), error = function(e) data.frame()) 59 | as_tbl(x) 60 | } 61 | 62 | model_data.tidy_model <- function(x) x$data 63 | 64 | #model_data.lm <- function(x) data_lm(x) 65 | 66 | #model_data.aov <- function(x) data_lm(x) 67 | 68 | #model_data.glm <- function(x) data_glm(x) 69 | 70 | #model_data.htest <- function(x) data_htest(x) 71 | 72 | -------------------------------------------------------------------------------- /R/utils-fit.R: -------------------------------------------------------------------------------- 1 | 2 | rmse <- function(m) { 3 | x <- unname(m$residuals) 4 | n <- length(x) 5 | p <- length(variable.names(m)) 6 | x <- (1 / (n - p)) * sum(x^2) 7 | sqrt(x) 8 | } 9 | 10 | #' nagelkerke r squared 11 | #' 12 | #' Estimate R^2 approximation for model object 13 | #' 14 | #' @param m A GLM model object. 15 | #' @return R^2 estimate. 16 | #' @details Equation taken from the following study: 17 | #' Nagelkerke, N. (1991). A Note on a General Definition of the Coefficient of Determination. Biometrika, 78(3), 691-692. doi:10.2307/2337038 18 | #' @export 19 | nagelkerke <- function(m) UseMethod("nagelkerke") 20 | 21 | #' @export 22 | nagelkerke.default <- function(m) { 23 | s <- summary(m) 24 | ll0 <- -s$null.deviance / 2 25 | ll1 <- -s$deviance / 2 26 | n <- length(m$residuals) 27 | 1 - exp((-(2/n) * (ll1 - ll0))) 28 | } 29 | 30 | mcfadden <- function(m) { 31 | s <- summary(m) 32 | ll0 <- -s$null.deviance / 2 33 | ll1 <- -s$deviance / 2 34 | 1 - ll1 / ll0 35 | } 36 | 37 | mcfadden.adj <- function(m) { 38 | s <- summary(m) 39 | ll0 <- -s$null.deviance / 2 40 | ll1 <- -s$deviance / 2 41 | 1 - (ll1 - ncol(m$model) - 1) / ll0 42 | } 43 | 44 | coxsnell <- function(m) { 45 | s <- summary(m) 46 | ll0 <- -s$null.deviance / 2 47 | ll1 <- -s$deviance / 2 48 | n <- length(m$residuals) 49 | 1 - ((ll0 / ll1)^(2 / n)) 50 | } 51 | -------------------------------------------------------------------------------- /R/utils.R: -------------------------------------------------------------------------------- 1 | #' Pipe operator 2 | #' 3 | #' See \code{magrittr::\link[magrittr]{\%>\%}} for details. 4 | #' 5 | #' @name %>% 6 | #' @rdname pipe 7 | #' @keywords internal 8 | #' @export 9 | #' @importFrom magrittr %>% 10 | #' @usage lhs \%>\% rhs 11 | NULL 12 | 13 | 14 | #' Convert object to tibble 15 | #' 16 | #' @inheritParams tibble::as_tibble 17 | #' @param validate Logical, indicating whether to validate data frame. 18 | #' Defaults to \code{FALSE} because validation, while probably offering more 19 | #' safety and consistency, also provides a noticeable slow down in 20 | #' performance. 21 | #' @return A tibble, class \code{c("tbl_df", "tbl", "data.frame")} 22 | #' @export 23 | as_tbl <- function(x, ..., validate = FALSE) { 24 | tibble::as_tibble(x, ..., validate = FALSE) 25 | } 26 | 27 | #' Create a tibble data frame 28 | #' 29 | #' @inheritParams tibble::tibble 30 | #' @return A tibble, class \code{c("tbl_df", "tbl", "data.frame")} 31 | #' @export 32 | tbl_frame <- function(...) { 33 | xs <- rlang::quos(..., .named = TRUE) 34 | if (length(xs) == 1L) { 35 | x <- eval_tidy(xs[[1]]) 36 | if (is.data.frame(x)) { 37 | return(as_tbl(x)) 38 | } 39 | } 40 | as_tbl(tibble:::lst_quos(xs, expand = TRUE)) 41 | } 42 | 43 | is_robust <- function(expr) { 44 | f <- rlang::expr_text(expr[[1]]) 45 | ("estimator" %in% names(expr) && expr$estimator == "mlr") || 46 | grepl("^robust\\:\\:glmRob$|^glmRob$|^MASS\\:\\:rlm$|^rlm$|^robustlmm\\:\\:rlmer$|^rlmer$", f) 47 | } 48 | 49 | is_ttest <- function(x) { 50 | grepl("^t|^htest|^ttest$", x, ignore.case = TRUE) 51 | } 52 | 53 | is_ols <- function(x) { 54 | grepl("^ols$|ordinary\\s?least\\s?squares", x, ignore.case = TRUE) 55 | } 56 | 57 | is_anova <- function(x) { 58 | grepl("anova|analysis of variance", x, ignore.case = TRUE) 59 | } 60 | 61 | is_log <- function(x) { 62 | grepl("^log$|^logistic|^binomial$", x, ignore.case = TRUE) 63 | } 64 | 65 | is_qlog <- function(x) { 66 | grepl("^quasi.?binom", x, ignore.case = TRUE) 67 | } 68 | 69 | is_pois <- function(x) { 70 | grepl("^pois$|poisson", x, ignore.case = TRUE) 71 | } 72 | 73 | is_qpois <- function(x) { 74 | grepl("^quasi.?pois", x, ignore.case = TRUE) 75 | } 76 | 77 | is_negbin <- function(x) { 78 | grepl("^negbin$|^negbinom$|negative\\s?binomial", x, ignore.case = TRUE) 79 | } 80 | 81 | is_sem <- function(x) { 82 | grepl("^sem$|structural equation|latent", x, ignore.case = TRUE) 83 | } 84 | 85 | is_mlm <- function(x) { 86 | grepl("^mlm$|multi.?level", x, ignore.case = TRUE) 87 | } 88 | 89 | std_model_type <- function(type) { 90 | type <- "mlm" 91 | type 92 | } 93 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | 2 | 3 | tidyselector <- function(data, ...) { 4 | vars <- tidyselect::vars_select(names(data), ...) 5 | if (length(vars) > 0) { 6 | data <- data[vars] 7 | } 8 | data 9 | } 10 | 11 | all_numeric <- function(x) { 12 | x[1:ncol(x)] <- lapply(x, coerce_numeric) 13 | x 14 | } 15 | 16 | #' @export 17 | coerce_numeric <- function(x) UseMethod("coerce_numeric") 18 | 19 | #' @export 20 | coerce_numeric.default <- function(x) { 21 | as.numeric(x) 22 | } 23 | 24 | #' @export 25 | coerce_numeric.character <- function(x) { 26 | x <- suppressWarnings(as.numeric(x)) 27 | if (all(is.na(x))) { 28 | stop("You've included a character (textual) variable. This function expected only numeric, integer, or factor variables.", 29 | call. = FALSE) 30 | } 31 | x 32 | } 33 | 34 | 35 | add_stars <- function(x) { 36 | x$stars <- make_stars(x) 37 | ## round p.value 38 | x$p.value <- round(x$p.value, 6) 39 | x 40 | } 41 | 42 | 43 | make_stars <- function(x) UseMethod("make_stars") 44 | 45 | make_stars.data.frame <- function(x) { 46 | if ("p.value" %in% names(x)) { 47 | x <- x$p.value 48 | } else if (any(grepl("^p$|^pval$|^pvalue$", names(x)))) { 49 | x <- x[[grep("^p$|^pval$|^pvalue$", names(x))[1]]] 50 | } 51 | make_stars(x) 52 | } 53 | 54 | make_stars.numeric <- function(x) { 55 | ifelse( 56 | is.na(x), "", 57 | ifelse( 58 | x < .10 & x >= .05, "+", 59 | ifelse( 60 | x < .05 & x >= .01, "*", 61 | ifelse( 62 | x < .01 & x >= .001, "**", 63 | ifelse( 64 | x <= .001 , "***", "" 65 | ))))) 66 | } 67 | 68 | make_stars.character <- function(x) { 69 | x <- as.numeric(x) 70 | make_stars(x) 71 | } 72 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | --- 4 | 5 | 6 | 7 | ```{r setup, include = FALSE} 8 | knitr::opts_chunk$set( 9 | collapse = TRUE, 10 | comment = "#>", 11 | fig.path = "man/figures/README-", 12 | out.width = "100%", 13 | eval = TRUE 14 | ) 15 | options(width = 100) 16 | polcom <- tidyversity::polcom 17 | ``` 18 | # tidymlm 19 | 20 | [![lifecycle](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://www.tidyverse.org/lifecycle/#experimental) 21 | 22 | 🎓 Tidy tools for academics 23 | 24 | 25 | ## \*\*\* This package is in very early development. Feedback is encouraged!!! \*\*\* 26 | 27 | ## Installation 28 | 29 | 35 | 36 | Install the development version from [Github](https://github.com/mkearney/tidymlm) with: 37 | 38 | ```{r install, eval=FALSE} 39 | ## install devtools if not already 40 | if (!requireNamespace("devtools", quietly = TRUE)) { 41 | install.packages("devtools") 42 | } 43 | ## install tidymlm from Github 44 | devtools::install_github("mkearney/tidymlm") 45 | ``` 46 | 47 | Load the package (it, of course, plays nicely with tidyverse). 48 | 49 | ```{r library} 50 | ## load tidyverse 51 | library(tidyverse) 52 | 53 | ## load tidymlm 54 | library(tidymlm) 55 | ``` 56 | 57 | ### Multilevel modeling (MLM) 58 | 59 | Estimate multilevel (mixed effects) models. 60 | 61 | ```{r mlm} 62 | lme4::sleepstudy %>% 63 | tidy_mlm(Reaction ~ Days + (Days | Subject)) %>% 64 | summary() 65 | ``` 66 | 67 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # tidymlm 5 | 6 | [![lifecycle](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://www.tidyverse.org/lifecycle/#experimental) 7 | 8 | 🎓 Tidy tools for 9 | academics 10 | 11 | ## \*\*\* This package is in very early development. Feedback is encouraged\!\!\! \*\*\* 12 | 13 | ## Installation 14 | 15 | 21 | 22 | Install the development version from 23 | [Github](https://github.com/mkearney/tidymlm) with: 24 | 25 | ``` r 26 | ## install devtools if not already 27 | if (!requireNamespace("devtools", quietly = TRUE)) { 28 | install.packages("devtools") 29 | } 30 | ## install tidymlm from Github 31 | devtools::install_github("mkearney/tidymlm") 32 | ``` 33 | 34 | Load the package (it, of course, plays nicely with tidyverse). 35 | 36 | ``` r 37 | ## load tidyverse 38 | library(tidyverse) 39 | 40 | ## load tidymlm 41 | library(tidymlm) 42 | ``` 43 | 44 | ### Multilevel modeling (MLM) 45 | 46 | Estimate multilevel (mixed effects) models. 47 | 48 | ``` r 49 | lme4::sleepstudy %>% 50 | tidy_mlm(Reaction ~ Days + (Days | Subject)) %>% 51 | summary() 52 | #> Linear mixed model fit by REML ['lmerMod'] 53 | #> Formula: Reaction ~ Days + (Days | Subject) 54 | #> Data: .data 55 | #> 56 | #> REML criterion at convergence: 1743.6 57 | #> 58 | #> Scaled residuals: 59 | #> Min 1Q Median 3Q Max 60 | #> -3.954 -0.463 0.023 0.463 5.179 61 | #> 62 | #> Random effects: 63 | #> Groups Name Variance Std.Dev. Corr 64 | #> Subject (Intercept) 612.1 24.74 65 | #> Days 35.1 5.92 0.07 66 | #> Residual 654.9 25.59 67 | #> Number of obs: 180, groups: Subject, 18 68 | #> 69 | #> Fixed effects: 70 | #> Estimate Std. Error t value 71 | #> (Intercept) 251.41 6.82 36.84 72 | #> Days 10.47 1.55 6.77 73 | #> 74 | #> Correlation of Fixed Effects: 75 | #> (Intr) 76 | #> Days -0.138 77 | ``` 78 | -------------------------------------------------------------------------------- /data/polcom.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mkearney/tidymlm/9d5e983df3b06b65dbb75ce9749744391d38221f/data/polcom.rda -------------------------------------------------------------------------------- /logo.R: -------------------------------------------------------------------------------- 1 | ## load ggplot2 2 | library(ggplot2) 3 | 4 | ## drawing 5 | cap1 <- data.frame( 6 | x = c(-.45, 0, .45, 0), 7 | y = c( .50, .65, .50, .35) - .225 8 | ) 9 | cap2 <- data.frame( 10 | x = c(-.28, -.28, .28, .28), 11 | y = c(.525, .30, .30, .525) - .225 12 | ) 13 | strng <- data.frame( 14 | x = c(.00, .36, .36, .345, .33, .33, 0), 15 | y = c(.51, .475, .27, .28, .26, .46, .49) - .225 16 | ) 17 | btn <- data.frame( 18 | x = c(-.045, 0, .045, 0), 19 | y = c(.50, .53, .50, .47) - .225 20 | ) 21 | 22 | ## background/border 23 | h1 <- hexagon::hexdf(1) 24 | h2 <- hexagon::hexdf(.975) 25 | h1$x <- round(h1$x, 2) 26 | h2$x <- round(h2$x, 2) 27 | 28 | ## create figures 29 | dir.create("man/figures") 30 | 31 | ## create and save hex sticker 32 | ggplot(h1, aes(x, y)) + 33 | geom_polygon(fill = "#000000", size = 1, colour = "#000000") + 34 | geom_polygon(data = h2, fill = "#006677", size = 0) + 35 | geom_polygon(data = cap2, fill = "#222222", size = .5, colour = "#000000") + 36 | geom_polygon(data = cap1, fill = "#444444", size = .5, colour = "#000000") + 37 | geom_polygon(data = strng, fill = "goldenrod", size = 0) + 38 | geom_polygon(data = btn, fill = "#000000", size = 0) + 39 | annotate("text", 0, -.175, label = "tidymlm", size = 6, 40 | colour = "#ffffff", family = "Consolas") + 41 | hexagon::theme_hexagon() + 42 | theme(plot.margin = margin(-6, -6, -9, -8, unit = "pt")) + 43 | ggsave("man/figures/logo.png", width = 1.74, height = 2, units = "in", 44 | bg = "transparent") 45 | 46 | ## ignore in build 47 | usethis::use_build_ignore("logo.R") 48 | 49 | -------------------------------------------------------------------------------- /make.R: -------------------------------------------------------------------------------- 1 | 2 | table(polcom$pp_party) 3 | 4 | x <- tidyversity:::fit_glmRob(m) 5 | x 6 | sapply(x, is.double) 7 | 8 | polcom %>% 9 | tidy_regression(ambiv_sexism_1>3 ~ pp_party + sex, type = "logistic", robust = TRUE) -> m 10 | tidy_summary() 11 | 12 | 13 | 14 | sem1 <- polcom %>% 15 | mutate(therm_2 = therm_2 / 10, 16 | therm_1 = 10 - therm_1 / 10) %>% 17 | tidy_sem_model(news =~ news_1 + news_2 + news_3 + news_4 + news_5 + news_6, 18 | ambiv_sexism =~ ambiv_sexism_1 + ambiv_sexism_2 + ambiv_sexism_3 + 19 | ambiv_sexism_4 + ambiv_sexism_5 + ambiv_sexism_6, 20 | partisan =~ a*therm_1 + a*therm_2, 21 | ambiv_sexism ~ age + sex + hhinc + edu + news + partisan) %>% 22 | tidy_sem() 23 | tidy_summary(sem1) 24 | 25 | model <- model_ 26 | 27 | 28 | measurement_and_structural <- function(model) { 29 | ## if no regression equation, then they're the same 30 | if (grepl("(<==)\\s{0,}~", model_)) { 31 | return(list(measurement = model, structural = model)) 32 | } 33 | ## store as structural model 34 | sm <- model 35 | ## drop regression lines for measurement model 36 | mm <- strsplit(model, "\\n")[[1]] 37 | mm <- grep("(?<==)\\s{0,}~", mm, perl = TRUE, invert = FALSE, value = TRUE) 38 | mm <- paste(mm, collapse = "\n") 39 | ## return model list 40 | list(measurement = mm, structural = sm) 41 | } 42 | 43 | measurement_and_structural(model) 44 | update(sem1) 45 | 46 | compare2cfa <- function(.data, model, robust = robust) { 47 | model <- measurement_and_structural(model) 48 | if (identical(model$measurement, model$structural)) { 49 | return(NULL) 50 | } 51 | if (robust) { 52 | estimator <- "mlr" 53 | } else { 54 | estimator <- "ml" 55 | } 56 | lavaan::cfa(model$measurement, data = .data, estimator = estimator) 57 | } 58 | -------------------------------------------------------------------------------- /man/as_tbl.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{as_tbl} 4 | \alias{as_tbl} 5 | \title{Convert object to tibble} 6 | \usage{ 7 | as_tbl(x, ..., validate = FALSE) 8 | } 9 | \arguments{ 10 | \item{x}{A list. Each element of the list must have the same length.} 11 | 12 | \item{...}{Other arguments passed on to individual methods.} 13 | 14 | \item{validate}{Logical, indicating whether to validate data frame. 15 | Defaults to \code{FALSE} because validation, while probably offering more 16 | safety and consistency, also provides a noticeable slow down in 17 | performance.} 18 | } 19 | \value{ 20 | A tibble, class \code{c("tbl_df", "tbl", "data.frame")} 21 | } 22 | \description{ 23 | Convert object to tibble 24 | } 25 | -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mkearney/tidymlm/9d5e983df3b06b65dbb75ce9749744391d38221f/man/figures/logo.png -------------------------------------------------------------------------------- /man/nagelkerke.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils-fit.R 3 | \name{nagelkerke} 4 | \alias{nagelkerke} 5 | \title{nagelkerke r squared} 6 | \usage{ 7 | nagelkerke(m) 8 | } 9 | \arguments{ 10 | \item{m}{A GLM model object.} 11 | } 12 | \value{ 13 | R^2 estimate. 14 | } 15 | \description{ 16 | Estimate R^2 approximation for model object 17 | } 18 | \details{ 19 | Equation taken from the following study: 20 | Nagelkerke, N. (1991). A Note on a General Definition of the Coefficient of Determination. Biometrika, 78(3), 691-692. doi:10.2307/2337038 21 | } 22 | -------------------------------------------------------------------------------- /man/pipe.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{\%>\%} 4 | \alias{\%>\%} 5 | \title{Pipe operator} 6 | \usage{ 7 | lhs \%>\% rhs 8 | } 9 | \description{ 10 | See \code{magrittr::\link[magrittr]{\%>\%}} for details. 11 | } 12 | \keyword{internal} 13 | -------------------------------------------------------------------------------- /man/tbl_frame.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/utils.R 3 | \name{tbl_frame} 4 | \alias{tbl_frame} 5 | \title{Create a tibble data frame} 6 | \usage{ 7 | tbl_frame(...) 8 | } 9 | \arguments{ 10 | \item{...}{A set of name-value pairs. Arguments are evaluated sequentially, 11 | so you can refer to previously created variables. These arguments are 12 | processed with \code{\link[rlang:quos]{rlang::quos()}} and support unquote via \code{!!} and 13 | unquote-splice via \code{!!!}.} 14 | } 15 | \value{ 16 | A tibble, class \code{c("tbl_df", "tbl", "data.frame")} 17 | } 18 | \description{ 19 | Create a tibble data frame 20 | } 21 | -------------------------------------------------------------------------------- /man/tidy_mlm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/model-mlm.R 3 | \name{tidy_mlm} 4 | \alias{tidy_mlm} 5 | \title{Multilevel model} 6 | \usage{ 7 | tidy_mlm(.data, model, robust = FALSE, ...) 8 | } 9 | \arguments{ 10 | \item{robust}{Logial indicating whether to use a robust estimator} 11 | 12 | \item{...}{Model formula to be estimated} 13 | 14 | \item{data}{Data frame containing variables in model} 15 | } 16 | \value{ 17 | A model object 18 | } 19 | \description{ 20 | Conduct multilevel model analysis (AKA mixed models) 21 | } 22 | -------------------------------------------------------------------------------- /tidymlm.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: No 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: XeLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace 22 | --------------------------------------------------------------------------------