Adjust default confidence level and fix for glance.rqs

DESCRIPTION

@@ -86,9 +86,10 @@ Suggests:
     lsmeans,
     betareg,
     robust,
-    akima
+    akima,
+    quantreg
 URL: http://github.com/tidyverse/broom
 BugReports: http://github.com/tidyverse/broom/issues
 VignetteBuilder: knitr
 License: MIT + file LICENSE
-RoxygenNote: 5.0.1
+RoxygenNote: 6.0.1

NAMESPACE

@@ -23,6 +23,7 @@ S3method(augment,prcomp)
 S3method(augment,rowwise_df)
 S3method(augment,rq)
 S3method(augment,rqs)
+S3method(augment,rqss)
 S3method(augment,smooth.spline)
 S3method(augment,survreg)
 S3method(augment,tbl_df)
@@ -69,6 +70,7 @@ S3method(glance,rlm)
 S3method(glance,rowwise_df)
 S3method(glance,rq)
 S3method(glance,rqs)
+S3method(glance,rqss)
 S3method(glance,smooth.spline)
 S3method(glance,stanreg)
 S3method(glance,summary.lm)
@@ -160,6 +162,7 @@ S3method(tidy,roc)
 S3method(tidy,rowwise_df)
 S3method(tidy,rq)
 S3method(tidy,rqs)
+S3method(tidy,rqss)
 S3method(tidy,sparseMatrix)
 S3method(tidy,spec)
 S3method(tidy,stanfit)
@@ -183,6 +186,7 @@ export(finish_glance)
 export(fix_data_frame)
 export(glance)
 export(inflate)
+export(rqss_fix)
 export(tidy)
 export(tidyMCMC)
 import(dplyr)

R/rq_tidiers.R

@@ -32,9 +32,9 @@ NULL
 #' The columns depend upon the confidence interval method selected.
 #' 
 #' @export
-tidy.rq <- function(x,se.type = "rank",conf.int = TRUE,conf.level = 0.95,alpha = 1 - conf.level, ...){
+tidy.rq <- function(x,se.type = "rank",conf.int = TRUE,conf.level = 0.9,alpha = 1 - conf.level, ...){
     #summary.rq often issues warnings when computing standard errors
-    rq_summary <- suppressWarnings(summary(x,se = se.type, alpha = alpha, ...))
+    rq_summary <- suppressWarnings(quantreg::summary.rq(x,se = se.type, alpha = alpha, ...))
     process_rq(rq_obj = rq_summary,se.type = se.type,conf.int = conf.int,conf.level = conf.level,...)
 }
 
@@ -45,9 +45,9 @@ tidy.rq <- function(x,se.type = "rank",conf.int = TRUE,conf.level = 0.95,alpha =
 #' method selected.
 #' 
 #' @export
-tidy.rqs <- function(x,se.type = "rank",conf.int = TRUE,conf.level = 0.95,alpha = 1 - conf.level, ...){
+tidy.rqs <- function(x,se.type = "rank",conf.int = TRUE,conf.level = 0.9,alpha = 1 - conf.level, ...){
     #summary.rq often issues warnings when computing standard errors
-    rq_summary <- suppressWarnings(summary(x,se = se.type,alpha = alpha, ...))
+    rq_summary <- suppressWarnings(quantreg::summary.rqs(x,se = se.type,alpha = alpha, ...))
     plyr::ldply(rq_summary,process_rq,se.type = se.type,conf.int = conf.int,conf.level = conf.level,...)
 }
 
@@ -76,6 +76,14 @@ tidy.nlrq <- function(x, conf.int = FALSE, conf.level = 0.95, ...){
     ret
 }
 
+#' @export
+tidy.rqss <- function(x,...){
+    nn <- c("term","edf","lambda","penalty","statistic","p.value")
+    ret <- fix_data_frame(summary(x)[['qsstab']])
+    ret <- setNames(ret,nn)
+    ret
+}
+
 #' @rdname rq_tidiers
 #' 
 #' @return \code{glance.rq} returns one row for each quantile (tau)
@@ -97,7 +105,15 @@ glance.rq <- function(x,...){
 }
 
 #' @export
-glance.rqs <- glance.rq
+glance.rqs <- function(x,...){
+    n <- length(fitted(x))
+    s <- summary(x)
+    data.frame(tau = x[["tau"]],
+               logLik = logLik(x),
+               AIC = AIC(x),
+               BIC = AIC(x,k = log(n)),
+               df.residual = sapply(s,'[[','rdf'))
+}
 
 #' @rdname rq_tidiers
 #' 
@@ -119,6 +135,16 @@ glance.nlrq <- function(x,...){
                df.residual = s[["rdf"]])
 }
 
+#' @export
+glance.rqss <- function(x,...){
+    s <- summary(x)
+    data.frame(tau = s[["tau"]],
+               fidelity = s[["fidelity"]],
+               edf = s[["edf"]],
+               logLik = logLik(x),
+               AIC = AIC(x,...))
+}
+
 #' @rdname rq_tidiers
 #' 
 #' @param newdata If provided, new data frame to use for predictions
@@ -218,6 +244,41 @@ augment.rqs <- function(x,data = model.frame(x), newdata, ...){
 #' @export
 augment.nlrq <- augment.nls
 
+#' @rdname rq_tidiers
+#' @export
+augment.rqss <- function(model,data,confint = FALSE,...){
+    if (missing(data)){
+        original <- model[["data"]]
+        original[[".tau"]] <- model[["tau"]]
+        original[[".fitted"]] <- quantreg::fitted.rqss(model)
+        original[[".resid"]] <- quantreg::resid.rqss(model)
+        return(original)
+    } else{
+        original <- data
+        original[[".tau"]] <- model[["tau"]]
+
+        if (confint){
+            interval <- "confidence"
+        }else{
+            interval <- "none"
+        }
+
+        preds <- quantreg::predict.rqss(object = model,
+                                        newdata = data,
+                                        interval = interval,...)
+        nn <- c(".fitted","lower","upper")
+        preds <- setNames(as.data.frame(preds),nn[seq_len(ncol(preds))])
+        return(unrowname(cbind(original,preds)))
+    }
+}
+
+#' @export
+rqss_fix <- function(formula,data,...){
+    model <- quantreg::rqss(formula = formula,data = data,...)
+    model[["data"]] <- data
+    model
+}
+
 
 #' Helper function for tidy.rq and tidy.rqs
 #'