version 1.5.3

DESCRIPTION

@@ -1,19 +1,20 @@
 Package: Qtools
 Type: Package
 Title: Utilities for Quantiles
-Version: 1.5.2
-Date: 2020-07-08
+Version: 1.5.3
+Date: 2020-11-26
 Authors@R: c(
-	person(given="Marco", family="Geraci", role=c("aut", "cph", "cre"), email="geraci@mailbox.sc.edu", comment = c(ORCID = "0000-0002-6311-8685")),
-	person(given="Alessio", family="Farcomeni", role=c("ctb"), email="alessio.farcomeni@uniroma2.it", comment = c("Contributions to midrq code", ORCID = "0000-0002-7104-5826"))
+	person(given="Marco", family="Geraci", role=c("aut", "cph", "cre"), email="marco.geraci@uniroma1.it", comment = c(ORCID = "0000-0002-6311-8685")),
+	person(given="Alessio", family="Farcomeni", role=c("ctb"), email="alessio.farcomeni@uniroma2.it", comment = c("Contributions to midrq code", ORCID = "0000-0002-7104-5826")),
+	person(given="Cinzia", family="Viroli", role=c("ctb"), email="cinzia.viroli@unibo.it", comment = c("Contributions to dqc code", ORCID = "0000-0002-3278-5266"))
 	)
-Maintainer: Marco Geraci <geraci@mailbox.sc.edu>
+Maintainer: Marco Geraci <marco.geraci@uniroma1.it>
 Depends: R (>= 3.0.0)
-Imports: utils, glmx, Gmisc, grDevices, graphics, stats, MASS, Matrix,
-        np, quantreg, mice, boot, numDeriv (>= 2016.8-1), Rcpp (>=
+Imports: utils, glmx, Gmisc, grDevices, graphics, gtools, stats, MASS,
+        Matrix, np, quantreg, boot, numDeriv (>= 2016.8-1), Rcpp (>=
         0.12.13)
 LinkingTo: Rcpp, RcppArmadillo
-Suggests: survey, knitr, rmarkdown
+Suggests: survey, mice, knitr, rmarkdown
 VignetteBuilder: knitr
 Description: Functions for unconditional and conditional quantiles. These
     include methods for transformation-based quantile regression,
@@ -25,9 +26,11 @@ Description: Functions for unconditional and conditional quantiles. These
 License: GPL (>= 2)
 LazyLoad: yes
 NeedsCompilation: yes
-Packaged: 2020-07-08 17:37:32 UTC; geraci
+Packaged: 2020-11-26 22:11:13 UTC; geraci
 Author: Marco Geraci [aut, cph, cre] (<https://orcid.org/0000-0002-6311-8685>),
   Alessio Farcomeni [ctb] (Contributions to midrq code,
-    <https://orcid.org/0000-0002-7104-5826>)
+    <https://orcid.org/0000-0002-7104-5826>),
+  Cinzia Viroli [ctb] (Contributions to dqc code,
+    <https://orcid.org/0000-0002-3278-5266>)
 Repository: CRAN
-Date/Publication: 2020-07-08 19:10:03 UTC
+Date/Publication: 2020-11-27 10:30:02 UTC

MD5

@@ -1,41 +1,43 @@
 fe06497acaf4f45999925d348c2605f9 *COPYING
-76eff11b8a5e31d44e3e0b2e39b12401 *DESCRIPTION
-871933940b068fc5b834ca97eddf1dae *NAMESPACE
-4521dca7c433e522845580f43f385db1 *NEWS
-ab1cb2b570f00a473b1c6a5a8e52ff08 *R/Qtools.R
-b5626f959485d3b7ec01993cb3cdfb15 *R/RcppExports.R
-3be7d5bff4e1cd5039f099308d9f944e *build/vignette.rds
+dbee6efd9d009849efcd1c971be93a12 *DESCRIPTION
+2dc3837306301bc24e06996217e3b3b7 *NAMESPACE
+3a4f8397e53ff4d35c7795d40775fe1c *NEWS
+6da858fec87020b84fa90e1c27d9b2af *R/Qtools.R
+e7a2084e0d1b8d0aa0f2a5bc7a24829e *R/RcppExports.R
+6786477f00211258bf22633fcfd608ab *build/vignette.rds
 3dff9a38fafb728f8a7768c97fefc873 *data/Chemistry.rda
 dfb988e33aac10f31d1045ebad9f59a7 *data/Orthodont.rda
 0644c30ecb4d319bbedd369c4e923a30 *data/esterase.rda
 881c8ca691cb6647cc01d9ba3fbccadb *data/labor.rda
 9c8bcf95bbc8b0f46d89a28adf23091d *inst/CITATION
-9ae6055998561bde22643d57885270c8 *inst/doc/Qtools.R
+3b1ba59beed2e67900e8595ed147fa7a *inst/doc/Qtools.R
 c915e36461edf1cc6fe8110601453ac3 *inst/doc/Qtools.Rmd
-80b11ff1f94c66fd2e9f10f871a31b29 *inst/doc/Qtools.html
+c1a597bf6cc95839e17c8ee32c07ce94 *inst/doc/Qtools.html
 0916eed82b271dfcb9648ab58911b607 *man/Chemistry.Rd
 84e2fbe6856cd922e38949dad6eb41c3 *man/GOFTest.Rd
 4c4c39236ff6eadcd500130b2b7fc9ab *man/KhmaladzeFormat.Rd
 33a2e4ab9d2222e79559bb722b23d2a8 *man/Orthodont.Rd
-720cc6f36c0fd34210c855b463424937 *man/Qtools-internal.Rd
-7af36be7fea83d115a0b87691a456b2f *man/Qtools-package.Rd
+85534e26696a38bb76e330bacdcbe600 *man/Qtools-internal.Rd
+ffb3c66db1731049d772d735905f6fe1 *man/Qtools-package.Rd
 f520f4b5f5a2057e7a865fd2eb6c7ebe *man/ao.Rd
-82fb16427fba7bdf970611d0a01fcf63 *man/cmidecdf.Rd
+622c45e16b294204bd7885beb4b0b6ea *man/cmidecdf.Rd
 f6d9dba5ea03006fbb27312a07a4abe9 *man/coef.midrq.Rd
 a863c02b9c2c87f94cc3da2a462ec7df *man/coef.rq.counts.Rd
 e20abc148f6fc98fd49c82426fbbb6c9 *man/coef.rqt.Rd
 6c56ff278d927a3a52927ed2f340b2f3 *man/confint.midquantile.Rd
+3cf7988c6a8ec786190fc1bd6ae8a8d5 *man/dqc.Rd
+d12a606449e83f286b060cb33fc5fa00 *man/dqcControl.Rd
 43c44ca1a89df6277d659c66cf8ed8ba *man/esterase.Rd
 e129269af800a17553d0020a0afbcbb5 *man/fitted.midrq.Rd
 f4154e83027dab30d5ea4d0094b0e3d6 *man/fitted.rq.counts.Rd
 ebcca106329211e8096808066c3e065d *man/fitted.rqt.Rd
 86a2870cceb9d4081cac2c0d425ddb22 *man/labor.Rd
 32a2910b347c73751589671dc0ce8f06 *man/maref.rqt.Rd
 65357814e1870014e182010997ab2f49 *man/mice.impute.rq.Rd
-96c1302a86a202381a4e5df6f505a5b3 *man/midq2q.Rd
+8622280eec0c13b920a5f2bea6833821 *man/midq2q.Rd
 66e6b21cd58d7adcb4c57823d1d8b9cb *man/midquantile.Rd
-e54f141a06b0b81da19c079e51bd0610 *man/midrq.Rd
-5486764eec64159aefba1b5737a0203e *man/midrqControl.Rd
+f343ba4a09eccffdf7cdf4e00dc0976f *man/midrq.Rd
+b5cf0b6593b7ca6122c1a19e31fb10c5 *man/midrqControl.Rd
 e1578d3591c5a95af23bb46ea248e320 *man/nlControl.Rd
 8ab8787fe56fd02980fef4459bf379fb *man/plot.midq2q.Rd
 8205f199cab980b51451db6bea333dce *man/plot.midquantile.Rd
@@ -47,6 +49,7 @@ d36db26e01337dd4a859ff9672b76eb8 *man/predict.rq.counts.Rd
 8a638fe54c72160ef3fb75534f97cb87 *man/predict.rrq.Rd
 52783333207381a90ac9e297848a1d7b *man/print.GOFTest.Rd
 6f79bae10aca754639619ac4bc4c3637 *man/print.cmidecdf.Rd
+cf21cdb52d0a3ecd9e66b337a60cbc2d *man/print.dqc.Rd
 a0f84674cf43136d09658b57221a4674 *man/print.midquantile.Rd
 8d784660887a33cb279a84516c48078a *man/print.midrq.Rd
 4a20f672c0507b765b4d76cb06142dd6 *man/print.qlss.Rd
@@ -60,12 +63,12 @@ fba292c8f414def35e7eab4cdea26153 *man/residuals.rqt.Rd
 f41178848f4af4c68968ac467c00ae67 *man/rq.counts.Rd
 4485ab2745f0f01a9de83f3932f3fa84 *man/rrq.Rd
 9dd69f16f5555e43e60bf9d27b1a5fef *man/sparsity.rqt.Rd
-ea7232e5a97f47c53b01cb23d8ea6e46 *man/summary.midrq.Rd
+e04e7345bba23bc1b19a96c48cc276d3 *man/summary.midrq.Rd
 72e6e4bbc23c455208a9ea0e8b7aa568 *man/summary.rqt.Rd
 871e332f0d387e7619b9efd590ae4b47 *man/summary.rrq.Rd
 25b5b174ea7bdee5c807718099a55a2a *man/tsrq.Rd
-7dc58c462dd5619c8b47bc1fcca60ccb *man/vcov.midrq.Rd
-17dfaa75146f6884d0dfd7d77ee3be3d *src/Qtools.cpp
-29ff76c9bf2be04e8e7d2c4ab21c161c *src/RcppExports.cpp
+a8efb751eb02adfa9d29086fe8f266df *man/vcov.midrq.Rd
+4de6097ba2874d69ae6b20dc4c331eb9 *src/Qtools.cpp
+278bdb036aa820f20f2bfb2ba6149deb *src/RcppExports.cpp
 c915e36461edf1cc6fe8110601453ac3 *vignettes/Qtools.Rmd
 7f0ed6eff17821727d34eb14d9685862 *vignettes/Qtools.bib

NAMESPACE

@@ -3,14 +3,14 @@ importFrom("graphics", "abline", "lines", "mtext", "par", "plot", "points", "seg
 importFrom("grDevices", "grey")
 importFrom("Gmisc", "fastDoCall")
 importFrom("glmx", "ao1")
+importFrom("gtools", "combinations")
 importFrom("Rcpp", "evalCpp")
 importFrom("utils", "packageDescription", "getFromNamespace")
 
 import("stats")
 import("boot")
 import("MASS")
 import("Matrix")
-import("mice")
 import("np")
 import("numDeriv")
 import("quantreg")
@@ -43,6 +43,7 @@ S3method(predict, rq.counts)
 S3method(predict, qlss)
 
 S3method(print, cmidecdf)
+S3method(print, dqc)
 S3method(print, GOFTest)
 S3method(print, midecdf)
 S3method(print, midquantile)

NEWS

@@ -65,3 +65,11 @@ Version 1.5.2 (July 8, 2020)
 
 =============================================
 
+Version 1.5.3 (November 26, 2020)
+
+- new functions for directional quantile classification (dqc)
+
+- fixed CRAN checks warning on stats::filter vs mice::filter
+
+=============================================
+

R/Qtools.R

@@ -3838,6 +3838,183 @@ addnoise <- function(x, centered = TRUE, B = 0.999)
     return(z)
 }
 
+######################################################################
+# Directional quantile classification
+######################################################################
+
+dqcControl <- function(tau.range = c(0.001, 0.999), nt = 10, ndir = 50, seed = NULL){
+
+list(tau.range = tau.range, nt = nt, ndir = ndir, seed = seed)
+
+}
+
+dqc <- function(formula, data, df.test, subset, weights, na.action, control = list(), fit = TRUE){
+
+cl <- match.call()
+mf <- match.call(expand.dots = FALSE)
+m <- match(c("formula", "data", "subset", "weights", "na.action"), names(mf), 0L)
+mf <- mf[c(1L, m)]
+mf$drop.unused.levels <- TRUE
+mf[[1L]] <- quote(stats::model.frame)
+mf <- eval(mf, parent.frame())
+mt <- attr(mf, "terms")
+intercept <- attr(terms.formula(formula, data = mf), "intercept") == 1
+
+# train dataset
+y <- model.response(mf)
+x <- model.matrix(mt, mf)
+w <- as.vector(model.weights(mf))
+if (!is.null(w) && !is.numeric(w)) 
+	stop("'weights' must be a numeric vector")
+if(intercept){
+	x <- x[,-c(1),drop = FALSE]
+}
+
+# test dataset
+if(!is.null(df.test)){
+	z <- model.matrix(formula[-2], df.test)
+	if(intercept){
+		z <- z[,-c(1),drop = FALSE]
+	}
+} else {
+	z <- NULL
+}
+
+if(is.null(names(control)))
+	control <- dqcControl()
+else {
+	control_default <- dqcControl()
+	control_names <- intersect(names(control), names(control_default))
+	control_default[control_names] <- control[control_names]
+	control <- control_default
+}
+
+FIT_ARGS <- list(x = x, z = z, y = y, control = control)
+
+if(!fit) return(FIT_ARGS)
+
+res <- do.call(dqc.fit, FIT_ARGS)
+
+res$call <- cl
+res$nx <- nrow(x)
+res$nz <- nrow(z)
+res$p <- ncol(x)
+res$control <- control
+res$terms <- mt
+res$term.labels <- colnames(x)
+class(res) <- "dqc"
+return(res)
+
+}
+
+dqc.fit <- function(x, z, y, control){
+
+.checkfn <- function(x, p) x*(p - (x < 0))
+
+if(!is.null(control$seed)) set.seed(control$seed)
+
+y <- as.factor(y)
+nx <- nrow(x)
+nz <- nrow(z)
+p <- ncol(x)
+
+ndir <- control$ndir
+nt <- control$nt
+groups <- sort(levels(y))
+ng <- length(groups)
+
+if(is.null(row.names(x))) row.names(x) <- 1:nx
+if(is.null(row.names(z))) row.names(z) <- 1:nz
+
+# generate grid of taus
+tau.range <- control$tau.range
+if(any(is.na(tau.range))){
+	stop("tau.range must not have NAs")
+}
+if(length(tau.range) == 1){
+	taus <- tau.range
+	nt <- 1
+}
+if(length(tau.range) == 2){
+	tau.range <- sort(tau.range)
+	taus <- seq(tau.range[1], tau.range[2], length = nt)
+}
+if(!length(tau.range) %in% c(1,2)){
+	stop("I cannot understand 'tau.range'. It must be of length 1 or 2.")
+}
+if(any(taus <= 0) | any(taus >= 1)){
+	stop("taus must be strictly in the unit interval (0,1)")
+}
+
+# order data
+ord <- order(y)
+x <- x[ord,]
+y <- y[ord]
+idx <- row.names(x)
+idz <- row.names(z)
+
+# marginal quantiles
+csi <- lapply(split(data.frame(x), y), function(z, taus) apply(z, 2, quantile, probs = taus), taus = taus)
+# element-wise signs for all combinations
+c_groups <- gtools::combinations(n = ng, r = 2, v = groups, repeats.allowed = FALSE)
+nc <- nrow(c_groups)
+dir.sgn <- apply(c_groups, 1, function(i, x) sign(x[i][[1]] - x[i][[2]]), x = csi) # (nt x p) x nc
+
+xu <- array(NA, dim = c(nx, ndir, nt), dimnames = list(obs = idx, dir = 1:ndir, tau = taus))
+zu <- array(NA, dim = c(nz, ndir, nt), dimnames = list(obs = idz, dir = 1:ndir, tau = taus))
+
+for (j in 1:nt) {
+	# generate grid of directions uniformly over the p-dimensional unit sphere
+	#theta <- matrix(runif(ndir * (p-1), 0, 2*pi), nrow = ndir, ncol = (p-1))
+	#u <- mvmesh::Polar2Rectangular(r = rep(1, ndir), theta = theta) # ndir x p
+	sgn.sel <- dir.sgn[seq(j, nt*p, by = nt),sample(1:nc, 1)]
+	out <- C_projfun(x, z, sgn.sel, nx, nz, p, ndir)
+	xu[,,j] <- out$xu
+	zu[,,j] <- out$zu
+}
+
+B <- ndir*nt
+xu <- matrix(as.numeric(xu), nrow = nx) # nx x B
+zu <- matrix(as.numeric(zu), nrow = nz) # nx x B
+
+ns <- as.integer(table(y))
+minn <- c(0, cumsum(ns[-ng]))
+maxn <- cumsum(ns)
+
+Phi <- C_phifun(xu, zu, nx, nz, B, ndir, ng, taus, minn, maxn)
+
+w <- colSums(Phi$out)
+w <- -w/sqrt(sum(w^2))
+
+dist.z <- matrix(0, nz, ng)
+for (i in 1:ng){
+	ss <- seq(i, ng*B, by = ng)
+	dist.z[,i] <- Phi$Phi_z[, ss, drop = FALSE]%*%w
+}
+index <- apply(dist.z, 1, which.min)
+
+ans <- data.frame(obs = idz, groups = factor(groups[index], levels = groups, labels = groups), value = apply(dist.z, 1, min))
+list(ans = ans, groups = groups)
+
+}
+
+print.dqc <- function(x, ...){
+
+z <- table(x$ans$groups)/x$nz*100
+
+cat("Directional quantile classification", "\n")
+if (!is.null(cl <- x$call)) {
+	cat("Call:\n")
+	dput(cl)
+	cat("\n")
+	cat("Classification proportions (%) by class:\n")
+	print(z)
+	cat("\n")
+}
+
+
+}
+
 ##################################################
 ### Khmaladze and other tests
 ##################################################

R/RcppExports.R

@@ -17,3 +17,11 @@ C_rcTest <- function(x, psi, omega, n, p, B) {
     .Call(`_Qtools_C_rcTest`, x, psi, omega, n, p, B)
 }
 
+C_projfun <- function(x, z, sgn, nx, nz, p, ndir) {
+    .Call(`_Qtools_C_projfun`, x, z, sgn, nx, nz, p, ndir)
+}
+
+C_phifun <- function(x, z, nx, nz, B, ndir, ng, taus, minn, maxn) {
+    .Call(`_Qtools_C_phifun`, x, z, nx, nz, B, ndir, ng, taus, minn, maxn)
+}
+

inst/doc/Qtools.R

@@ -1,4 +1,4 @@
-## ---- echo=FALSE, warning = FALSE----------------------------------------
+## ---- echo=FALSE, warning = FALSE---------------------------------------------
 library(knitr)
 #Determine the output format of the document
 outputFormat   = opts_knit$get("rmarkdown.pandoc.to")