small update and code coverage added

.travis.yml

@@ -4,12 +4,18 @@ language: R
 sudo: false
 cache: packages
 
-r_check_args: --as-cran --use-valgrind
+r_check_args: '--as-cran --use-valgrind'
 
 env:
   - VALGRIND_OPTS='--leak-check=full --track-origins=yes'
 
 addons:
   apt:
     packages:
-      - valgrind
+      - valgrind
+
+r_packages:
+  - covr
+
+after_success:
+  - Rscript -e 'library(covr); codecov()'

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: pseudorank
 Title: Pseudo-Ranks
-Version: 0.1.0
-Date: 2018-06-08
+Version: 0.2.1
+Date: 2018-07-07
 Authors@R: c(person("Martin Happ", role = c("aut", "cre"),
                       email = "[email protected]",
                       comment = c(ORCID = "0000-0003-0009-2665")),
@@ -16,6 +16,7 @@ LazyData: true
 Depends: R (>= 3.4.0)
 Imports: Rcpp (>= 0.12.16), doBy
 LinkingTo: Rcpp
+SystemRequirements: C++11
 URL: http://github.com/happma/pseudorank
 BugReports: http://github.com/happma/pseudorank/issues
 RoxygenNote: 6.0.1

NAMESPACE

@@ -1,4 +1,5 @@
 useDynLib(pseudorank, .registration=TRUE)
+export(psrank, psrank.numeric, psrank.formula, psrankCpp, order_vec)
 export(psrank, psrank.numeric, psrank.formula, hettmansperger_norton_test, hettmansperger_norton_test.numeric, hettmansperger_norton_test.formula)
 S3method(psrank, numeric)
 S3method(psrank, formula)
@@ -9,4 +10,4 @@ S3method(hettmansperger_norton_test, numeric)
 importFrom(Rcpp, evalCpp)
 importFrom("stats", "model.frame")
 importFrom("doBy", "summaryBy")
-importFrom("stats", "pnorm")
+importFrom("stats", "pnorm")

R/RcppExports.R

@@ -1,7 +1,11 @@
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
-psrank <- function(data, group, n) {
-    .Call(`_pseudorank_psrank`, data, group, n)
+order_vec <- function(data) {
+    .Call(`_pseudorank_order_vec`, data)
+}
+
+psrankCpp <- function(data, group, n) {
+    .Call(`_pseudorank_psrankCpp`, data, group, n)
 }
 

R/S3method.R

@@ -15,7 +15,6 @@
 #' @param ... further arguments
 #' @return Returns a numerical vector containing the pseudo-ranks
 #' @rdname psrank
-#' @seealso \code{\link{rank}}.
 #' @example R/example_1.txt
 #' @keywords export
 psrank <- function(data, ...){
@@ -44,7 +43,7 @@ psrank.formula <- function(formula, data, ...){
 #' @rdname hettmansperger_norton_test
 #' @param data numeric vector containing the data or a data.frame
 #' @param group ordered factor vector for the groups
-#' @param alternative either decreasing or increasing
+#' @param alternative either decreasing (trend k, k-1, ..., 1) or increasing (1, 2, ..., k) or custom (then argument trend must be used)
 #' @param formula formula object
 #' @param trend custom numeric vector indicating the trend for the custom alternative, only used if alternative = "custom"
 #' @param ... further arguments are ignored
@@ -55,14 +54,14 @@ psrank.formula <- function(formula, data, ...){
 #' @keywords export
 hettmansperger_norton_test <- function(data, ...) {
   UseMethod("hettmansperger_norton_test")
-}  
+}
 
 #' @method hettmansperger_norton_test numeric
 #' @rdname hettmansperger_norton_test
 #' @keywords export
 hettmansperger_norton_test.numeric <- function(data, group, alternative = c("decreasing", "increasing", "custom"), trend = NULL, ...) {
   return(hettmansperger_norton_test_internal(data, group, alternative = alternative, formula = NULL, trend = trend, ...))
-}  
+}
 
 #' @method hettmansperger_norton_test formula
 #' @rdname hettmansperger_norton_test
@@ -71,4 +70,4 @@ hettmansperger_norton_test.formula <- function(formula, data, alternative = c("d
   model <- model.frame(formula, data = data)
   colnames(model) <- c("data", "group")
   return(hettmansperger_norton_test_internal(model$data, model$group, alternative = alternative, formula = formula, trend = trend, ...))
-}  
+}

R/hettmansperger.R

@@ -24,9 +24,9 @@ J <- function(d) {
 #' @references Hettmansperger, T. P., & Norton, R. M. (1987). Tests for patterned alternatives in k-sample problems. Journal of the American Statistical Association, 82(397), 292-299
 #' @keywords internal
 hettmansperger_norton_test_internal <- function(data, group, alternative = c("decreasing", "increasing", "custom"), formula = NULL, trend = NULL, ...) {
-  
+
   stopifnot(is.numeric(data), is.factor(group), is.ordered(group))
-  
+
   n <- as.numeric(as.matrix(table(group)))
   a <- length(n)
   df <- data.frame(pranks = psrank.numeric(data, group), group = group)
@@ -35,7 +35,7 @@ hettmansperger_norton_test_internal <- function(data, group, alternative = c("de
   n <- summaryBy(pranks~group,data=df, FUN = length)[, 2]
   alternative <- match.arg(alternative)
   w <- rep(1, a)
-  switch(alternative, 
+  switch(alternative,
          decreasing={
            w <- a:1
          },
@@ -47,15 +47,15 @@ hettmansperger_norton_test_internal <- function(data, group, alternative = c("de
            w <- trend
          }
   )
-  
+
   W <- diag(n)%*%(I(a) - 1/sum(n)*J(a)%*%diag(n))
   v2 <- 1/sum(n)^2*1/(sum(n)-1)*sum( (df$pranks - (sum(n)+1)/2 )^2 )
   sigmaHat2 <- sum(n)*v2*t(w)%*%W%*%diag(1/n)%*%W%*%w
-  
+
   test <- sqrt(sum(n))*t(w)%*%W%*%pHat*1/sqrt(sigmaHat2)
-  
+
   pValue <- 1 - pnorm(test)
-  
+
   output <- list()
   output$test <- test
   output$pValue <- pValue
@@ -65,9 +65,9 @@ hettmansperger_norton_test_internal <- function(data, group, alternative = c("de
   output$formula <- formula
   output$trend <- trend
   class(output) <- "pseudorank"
-  
+
   return(output)
-  
+
 }
 
 #' @keywords export

R/pseudoranks.R

@@ -4,6 +4,11 @@
 ###
 ################################################################################
 
+# ps_rank <- function(data, group, n) {
+#   ord <- pseudorank::order_vec(data) + 1
+#   #sortback <- match(data, data[ord])
+#   return(pseudorank::psrankCpp(data[ord], group[ord],n))
+# }
 
 #globalVariables("_pseudoranks_psrank")
 
@@ -18,16 +23,19 @@
 recursiveCalculation <- function(data, group) {
 
   stopifnot(is.numeric(data), is.factor(group))
+  group <- as.numeric(group)
+
   n <- as.numeric(as.matrix(table(group)))
 
+  # balanced group sizes
   if( identical(n,rep(n[1],length(n)))  ) {
     return(rank(data, ties.method = "average"))
-  } else {
-    id <- 1:length(data)
-    df <- matrix(c(data = data, group = group, id = id), ncol=3)
-    df <- df[order(df[, 1]),]
-    prank <- .Call(`_pseudorank_psrank`, df[, 1], df[, 2], n)
-    sortback <- match(id, df[, 3])
+  }
+  else {
+    ord <- .Call(`_pseudorank_order_vec`, data) + 1
+    data_sorted <- data[ord]
+    sortback <- match(data, data_sorted)
+    prank <- .Call(`_pseudorank_psrankCpp`, data_sorted, group[ord], n)
     return(prank[sortback])
   }
 }
@@ -37,26 +45,35 @@ recursiveCalculation <- function(data, group) {
 ## ----------------------------------
 # pairwise <- function(data, group, n){
 #   group <- factor(group, labels = 1:length(n))
-#   df <- data.frame(data = data, group = group, id = 1:sum(n))
-#   g <- levels(group)
-#   df$group <- factor(df$group, labels = 1:length(n))
+#   df <- data.table(data = data, group = group, id = 1:sum(n))
+#   a <- length(n)
+#   
+#   df$group <- factor(df$group, labels = 1:a)
 #   df$group <- as.numeric(df$group)
 #   prank <- rep(0, length(data))
-#   for(i in 1:length(n)) {
-#     iset <- subset(df, df$group == i)$data
-#     internal <- rank(iset, ties.method = "average")
-#     for(j in 1:n[i]) {
-#       prank[cumsum(c(0,n))[i]+j] <- (internal[j]-1/2)*1/n[i]
-#       for(k in setdiff(1:length(n),i)) {
-#         pset <- subset(df, df$group==i | df$group == k)$data
-#         index <- which(pset == iset[j])
-#         prank[cumsum(c(0,n))[i]+j] <- 1/n[k]*(rank(pset, ties.method = "average")[index] - internal[j]) + prank[cumsum(c(0,n))[i]+j] 
-#       }
-#       prank[cumsum(c(0,n))[i]+j] <- prank[cumsum(c(0,n))[i]+j]*sum(n)/length(n) + 1/2
+#   
+#   L <- list(as.matrix(diag(a), ncol = a))
+#   tmp <- df
+#   
+#   for(i in 1:a) {
+#     L[[i]] <- as.matrix(diag(sum(n)), ncol = sum(n))*0
+#     for(j in 1:a) {
+#       tmp <- copy(df)
+#       tmp[group %in% c(i,j), data:=rank(data, ties.method = "average")] 
+#       L[[i]][, j] <- copy(tmp[, data])
 #     }
 #   }
+#   
+#   for(i in 1:sum(n)) {
+#     g <- df$group[i]
+#     prank[i] <- 1/n[g]*(L[[g]][i, g]-1/2)
+#     for(j in 1:a) {
+#       prank[i] <- prank[i]+1/n[j]*(L[[j]][i, g] - L[[g]][i, g])
+#     }
+#   }
+#   prank <- prank*sum(n)/a+1/2
 #   return(prank)
-# }
+# } 
 # 
 # 
 # AB <- function(data, group){

pseudorank.Rproj

@@ -0,0 +1,19 @@
+Version: 1.0
+
+RestoreWorkspace: Default
+SaveWorkspace: Default
+AlwaysSaveHistory: Default
+
+EnableCodeIndexing: Yes
+UseSpacesForTab: Yes
+NumSpacesForTab: 2
+Encoding: UTF-8
+
+RnwWeave: Sweave
+LaTeX: pdfLaTeX
+
+BuildType: Package
+PackageUseDevtools: Yes
+PackageInstallArgs: --no-multiarch --with-keep.source
+PackageCheckArgs: --as-cran
+PackageRoxygenize: rd

src/RcppExports.cpp

@@ -5,22 +5,34 @@
 
 using namespace Rcpp;
 
-// psrank
-Rcpp::NumericVector psrank(Rcpp::NumericVector& data, Rcpp::NumericVector& group, Rcpp::NumericVector& n);
-RcppExport SEXP _pseudorank_psrank(SEXP dataSEXP, SEXP groupSEXP, SEXP nSEXP) {
+// order_vec
+Rcpp::NumericVector order_vec(Rcpp::NumericVector& data);
+RcppExport SEXP _pseudorank_order_vec(SEXP dataSEXP) {
+BEGIN_RCPP
+    Rcpp::RObject rcpp_result_gen;
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type data(dataSEXP);
+    rcpp_result_gen = Rcpp::wrap(order_vec(data));
+    return rcpp_result_gen;
+END_RCPP
+}
+// psrankCpp
+Rcpp::NumericVector psrankCpp(Rcpp::NumericVector& data, Rcpp::NumericVector& group, Rcpp::NumericVector& n);
+RcppExport SEXP _pseudorank_psrankCpp(SEXP dataSEXP, SEXP groupSEXP, SEXP nSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
     Rcpp::RNGScope rcpp_rngScope_gen;
     Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type data(dataSEXP);
     Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type group(groupSEXP);
     Rcpp::traits::input_parameter< Rcpp::NumericVector& >::type n(nSEXP);
-    rcpp_result_gen = Rcpp::wrap(psrank(data, group, n));
+    rcpp_result_gen = Rcpp::wrap(psrankCpp(data, group, n));
     return rcpp_result_gen;
 END_RCPP
 }
 
 static const R_CallMethodDef CallEntries[] = {
-    {"_pseudorank_psrank", (DL_FUNC) &_pseudorank_psrank, 3},
+    {"_pseudorank_order_vec", (DL_FUNC) &_pseudorank_order_vec, 1},
+    {"_pseudorank_psrankCpp", (DL_FUNC) &_pseudorank_psrankCpp, 3},
     {NULL, NULL, 0}
 };