├── .gitignore ├── .gitmodules ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── THANKS ├── TODO ├── forLater ├── estimateLambda.Rd ├── fixedLassoPoly.Rd ├── funs.fixed.R ├── funs.fs.R ├── funs.ftests.R ├── josh │ ├── funs.sims.R │ ├── selectiveInference │ │ └── R │ │ │ └── cv.R │ ├── sim.aicstop.R │ ├── sim.carve.R │ ├── sim.cv.R │ ├── sim.cvlar.R │ ├── sim.datasplit.R │ ├── sim.groupfs.R │ ├── sim.selectedmodel.R │ ├── sim.splitcv.R │ └── tests │ │ └── test.cv.R ├── maxZ │ ├── forLater │ └── funs.constraints.R └── yuval │ ├── sample_truncnorm.R │ └── test_sampler.R ├── selectiveInference ├── DESCRIPTION ├── NAMESPACE ├── R │ ├── funs.ROSI.R │ ├── funs.ROSI.side.R │ ├── funs.common.R │ ├── funs.fixed.R │ ├── funs.fixedCox.R │ ├── funs.fixedLogit.R │ ├── funs.fs.R │ ├── funs.groupfs.R │ ├── funs.inf.R │ ├── funs.lar.R │ ├── funs.manymeans.R │ ├── funs.max.R │ ├── funs.quadratic.R │ ├── funs.randomized.R │ ├── funs.randomizedMLE.R │ ├── funs.sampler.R │ └── linear.tests.R ├── man │ ├── ROSI.Rd │ ├── TG.interval.Rd │ ├── TG.limits.Rd │ ├── TG.pvalue.Rd │ ├── debiasingMatrix.Rd │ ├── estimateSigma.Rd │ ├── factorDesign.Rd │ ├── fixedLassoInf.Rd │ ├── forwardStop.Rd │ ├── fs.Rd │ ├── fsInf.Rd │ ├── groupfs.Rd │ ├── groupfsInf.Rd │ ├── lar.Rd │ ├── larInf.Rd │ ├── manyMeans.Rd │ ├── plot.fs.Rd │ ├── plot.lar.Rd │ ├── predict.fs.Rd │ ├── predict.groupfs.Rd │ ├── predict.lar.Rd │ ├── randomizedLasso.Rd │ ├── randomizedLassoInf.Rd │ ├── scaleGroups.Rd │ ├── selectiveInference-internal.Rd │ └── selectiveInference.Rd └── src │ ├── .gitignore │ ├── Makevars │ ├── Rcpp-debias.cpp │ ├── Rcpp-matrixcomps.cpp │ └── Rcpp-randomized.cpp └── tests ├── debiased_lasso ├── comparison_scaled.R ├── comparison_unscaled.R ├── javanmard_montanari.R ├── test_debiased_coverage.R ├── test_debiasing.R └── test_debiasing_wide.R ├── lee_high_dim └── test_lee.R ├── liu_high_dim_full └── test_liu_full.R ├── randomized ├── nonnull.R ├── python_comparison.R ├── test_MLE.R ├── test_instances.R ├── test_randomized.R ├── test_randomized_simple.R ├── test_sampler.R ├── timing.R └── timing_smaller.R ├── test.R ├── test.categorical.R ├── test.ci.R ├── test.cv.R ├── test.fixed.R ├── test.fs.R ├── test.fs.selected.R ├── test.fs_maxZ.R ├── test.groupfs.R ├── test.groupfs.rob.R ├── test.lar.R ├── test.manymeans.R ├── test_QP.R └── unifTest.R /.gitignore: -------------------------------------------------------------------------------- 1 | *.rds 2 | tests/*.rds 3 | tests/*/*.rds 4 | tests/*/*/*.rds 5 | tests/*.csv 6 | tests/*/*.csv 7 | tests/*/*/*.csv 8 | **DS_Store** 9 | **Rcheck** 10 | **tar.gz 11 | **Rapp.history 12 | **.pdf 13 | **.RData 14 | **.o 15 | **.so 16 | forLater/josh/** 17 | */R/RcppExports.R 18 | */src/RcppExports.cpp 19 | *~ 20 | */*~ 21 | */*/*~ 22 | # this code is copied from C-software 23 | selectiveInference/src/matrixcomps.* 24 | selectiveInference/src/debias.* 25 | selectiveInference/src/randomized_lasso.* 26 | selectiveInference/src/quadratic_program* 27 | selectiveInference/src/selective_mle* -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "C-software"] 2 | path = C-software 3 | url = https://github.com/selective-inference/C-software.git 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | cache: packages 3 | sudo: false 4 | r: 5 | #- oldrel 6 | - release 7 | - devel 8 | addons: 9 | apt: 10 | packages: libmpfr-dev 11 | warnings_are_errors: true 12 | before_install: 13 | - tlmgr install index # for texlive and vignette? 14 | - R -e 'install.packages(c("Rcpp", "intervals", "adaptMCMC", "glmnet"), repos="http://cloud.r-project.org")' 15 | - cd C-software 16 | - git submodule init 17 | - git submodule update 18 | - cd .. 19 | - make src 20 | - make Rcpp 21 | - cd selectiveInference 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | Rcpp: 2 | - rm -f selectiveInference/src/RcppExports.cpp 3 | - rm -f selectiveInference/R/RcppExports.R 4 | - Rscript -e "library(Rcpp); Rcpp::compileAttributes('selectiveInference')" 5 | 6 | install: Rcpp src 7 | R CMD INSTALL selectiveInference 8 | 9 | build: src 10 | R CMD build selectiveInference 11 | 12 | src: 13 | cp C-software/src/* selectiveInference/src 14 | 15 | check: Rcpp build 16 | R CMD build selectiveInference 17 | R CMD check selectiveInference_1.2.5.tar.gz --as-cran # fix this to be a script variable -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # R-software 2 | R software for [selective inference](http://cran.r-project.org/web/packages/selectiveInference/). 3 | Authors: Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid, Jelena Markovic 4 | Maintainer: Rob Tibshirani 5 | 6 | New tools for inference after selection, for use with forward stepwise regression, least angle regression, the lasso, and the many means problem. The package is available on [CRAN](http://cran.r-project.org/web/packages/selectiveInference/). See [this paper](http://www.pnas.org/content/112/25/7629.full) for a high level introduction to selective inference. 7 | 8 | Code is in the directory selectiveInference/R. 9 | * funs.common.R: Basic functions used by many other functions, such as standardization. 10 | * funs.fixed.R: Inference for LASSO at a fixed, deterministic value of lambda. 11 | * funs.fs.R: Inference for forward stepwise. 12 | * funs.groupfs.R: Inference for forward stepwise with groups of variables, e.g. factors. 13 | * funs.inf.R: Common functions for inference with fixed, fs, lar, and manymeans (but not group). 14 | * funs.lar.R: Inference for least angle regression. 15 | * funs.max.R: Some numerical approximations. Deprecated? 16 | 17 | ## Installation 18 | The latest release of the package can be installed through CRAN: 19 | 20 | ```R 21 | install.packages("selectiveInference") 22 | ``` 23 | Code in repo is under development and may be unstable. 24 | 25 | ## For development 26 | 27 | As the C code is shared between python and R, it is in a git submodule. Current version can be grabbed with 28 | 29 | ``` 30 | git submodule init 31 | git submodule update 32 | ``` 33 | 34 | ## To install 35 | 36 | ``` 37 | make install 38 | ``` 39 | 40 | ## To test 41 | 42 | ``` 43 | make check 44 | ``` 45 | 46 | These tests are also run on [travis](http://travis-ci.org) based on .travis.yml setup. -------------------------------------------------------------------------------- /THANKS: -------------------------------------------------------------------------------- 1 | Selective Inference Team 2 | ------------------------ 3 | 4 | Contributors to this project include: 5 | 6 | Yuval Benjamini 7 | Leonard Blier 8 | Will Fithian 9 | Jason Lee 10 | Joshua Loftus 11 | Stephen Reid 12 | Dennis Sun 13 | Yuekai Sun 14 | Jonathan Taylor 15 | Xiaoying Tian 16 | Ryan Tibshirani 17 | Robert Tibshirani 18 | 19 | 20 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | 2 | Ryan's ideas: 3 | 4 | use mpfr (multi-prec) for tnorm.surv etc 5 | 6 | use root finding too 7 | -------------------------------------------------------------------------------- /forLater/estimateLambda.Rd: -------------------------------------------------------------------------------- 1 | \name{estimateLambda} 2 | \alias{estimateLambda} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Estimates the lasso tuning parameter lambda. 6 | } 7 | \description{ 8 | Estimates the lasso tuning parameter lambda, for use in the selectiveInference 9 | package 10 | } 11 | \usage{ 12 | estimateLambda(x, sigma, nsamp=1000) 13 | } 14 | \arguments{ 15 | \item{x}{ 16 | Matrix of predictors (n by p) 17 | } 18 | \item{sigma}{ 19 | Estimate of error standard deviation 20 | } 21 | \item{nsamp}{Number of Monte carlo samples used for the estimation.} 22 | } 23 | \details{ 24 | This function estimates the lasso tuning parameter lambda, using the estimate 25 | 2*E(||X^T eps||_infty) where eps ~ N(0,sigma^2), a vector of length n. 26 | This estimate was proposed by Negahban et al (2012). 27 | } 28 | \value{ 29 | \item{sigmahat}{The estimate of sigma} 30 | \item{df}{The degrees of freedom of lasso fit used} 31 | } 32 | \references{ 33 | Negahban, S. N., 34 | Ravikumar, P., 35 | Wainwright, M. J. 36 | and Yu, B. 37 | (2012). A unified 38 | framework for high-dimensional analysis of 39 | M-estimators with decomposable regularizers. 40 | Statistical Science vol. 27, p 538-557. 41 | } 42 | 43 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 44 | 45 | \examples{ 46 | #NOT RUN 47 | #set.seed(43) 48 | #n=50 49 | #p=10 50 | #sigma=.7 51 | #x=matrix(rnorm(n*p),n,p) 52 | #x=scale(x,T,F) 53 | #beta=c(3,2,0,0,rep(0,p-4)) 54 | #y=x%*%beta+sigma*rnorm(n) 55 | #y=y-mean(y) 56 | # 57 | #estimate lambda usingthe known value of sigma 58 | #lamhat=estimateLambda(x,sigma=.7) 59 | # 60 | #first estimate sigma 61 | #sigmahat=estimateSigma(x,y)$sigmahat 62 | #lamhat=estimateLambda(x,sigma=sigmahat) 63 | 64 | #compare to estimate from cv 65 | 66 | #out=cv.glmnet(x,y) 67 | #out$lambda.min*n #remember that value from glmnet must be 68 | # multiplied by n, to make it comparable. 69 | } 70 | 71 | -------------------------------------------------------------------------------- /forLater/fixedLassoPoly.Rd: -------------------------------------------------------------------------------- 1 | \name{fixedLassoPoly} 2 | \alias{fixedLassoPoly} 3 | 4 | \title{ 5 | Compute polyhedral constraints for a LASSO problem with 6 | a fixed value of lambda. 7 | } 8 | \description{ 9 | Compute polyhedral representation of the selection region of Lee et al. (2016). 10 | By construction, y should satisfy A %*% y elementwise less then or equal b. 11 | } 12 | \usage{ 13 | fixedLassoPoly(X, y, lambda, beta, active, inactive = FALSE) 14 | } 15 | \arguments{ 16 | \item{X}{ 17 | Design matrix of LASSO problem. 18 | } 19 | \item{y}{ 20 | Response of LASSO problem. 21 | } 22 | \item{lambda}{ 23 | Value of regularization parameter. 24 | } 25 | \item{beta}{ 26 | Solution of LASSO problem with regularization parameter set to lambda. 27 | } 28 | \item{active}{ 29 | Active set of the LASSO problem as a boolean vector. Should correspond 30 | to the non-zeros of beta. 31 | } 32 | \item{inactive}{ 33 | Form the inactive constraints as well? 34 | } 35 | } 36 | \details{ 37 | This function computes 38 | the polyhedral representation of the selection region of Lee et al. (2016). 39 | } 40 | 41 | \value{ 42 | \item{A}{Linear part of the affine inequalities.} 43 | \item{b}{RHS offset the affine inequalities.} 44 | } 45 | 46 | \references{ 47 | Jason Lee, Dennis Sun, Yuekai Sun, and Jonathan Taylor (2016). 48 | Exact post-selection inference, with application to the lasso. Annals of Statistics, 44(3), 907-927. 49 | 50 | Jonathan Taylor and Robert Tibshirani (2017) Post-selection inference for math L1-penalized likelihood models. 51 | Canadian Journal of Statistics, xx, 1-21. (Volume still not posted) 52 | } 53 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 54 | 55 | \examples{ 56 | 57 | set.seed(43) 58 | n = 50 59 | p = 10 60 | sigma = 1 61 | 62 | x = matrix(rnorm(n*p),n,p) 63 | x = scale(x,TRUE,TRUE) 64 | 65 | beta = c(3,2,rep(0,p-2)) 66 | y = x\%*\%beta + sigma*rnorm(n) 67 | 68 | # first run glmnet 69 | gfit = glmnet(x,y,standardize=FALSE) 70 | 71 | # extract coef for a given lambda; note the 1/n factor! 72 | # (and we don't save the intercept term) 73 | lambda = .8 74 | beta = coef(gfit, s=lambda/n, exact=TRUE)[-1] 75 | active = (beta != 0) 76 | 77 | fixedLassoPoly(x, y, lambda, beta, active) 78 | fixedLassoPoly(x, y, lambda, beta, active, inactive=TRUE) 79 | 80 | } 81 | -------------------------------------------------------------------------------- /forLater/josh/funs.sims.R: -------------------------------------------------------------------------------- 1 | # Functions for simulation/testing 2 | 3 | randomGroupSizes <- function(G, lambda = 2) return(2 + rpois(G, lambda)) 4 | 5 | randomGroups <- function(G, lambda = 2) { 6 | rles <- randomGroupSizes(G, lambda) 7 | return(rep(1:G, rles)) 8 | } 9 | 10 | randomIndexFixedP <- function(p, G) sort(c(sample(1:G), sample(1:G, size = p-G, replace=T))) 11 | 12 | randomFactorDesign <- function(n, G, lambda = 2) { 13 | if (n < (1+lambda)*G) stop("Larger n required to avoid duplicate columns") 14 | rles <- randomGroupSizes(G, lambda) 15 | print(rles) 16 | df <- data.frame(do.call(cbind, lapply(rles, function(g) { 17 | sample(LETTERS[1:g], n, replace = TRUE, prob = runif(g)) 18 | })), stringsAsFactors = TRUE) 19 | if (any(apply(df, 2, function(col) length(unique(col))) == 1)) return(randomFactorDesign(n, G, lambda)) 20 | fd <- factorDesign(df) 21 | if (any(duplicated(fd$x, MARGIN = 2))) return(randomFactorDesign(n, G, lambda)) 22 | return(list(df=df, fd=fd)) 23 | } 24 | 25 | randomFactorsFixedP <- function(p, G) { 26 | # index <- 27 | } 28 | 29 | randomGaussianFixedP <- function(n, p, G = p, sparsity = 0, snr = 0, sigma = 1, rho = 0) { 30 | index <- 1:p 31 | if (G < p) index <- randomIndexFixedP(p, G) 32 | x <- matrix(rnorm(n*p), nrow=n) 33 | if (rho != 0) { 34 | z <- matrix(rep(t(rnorm(n)), p), nrow = n) 35 | x <- sqrt(1-rho)*x + sqrt(rho)*z 36 | } 37 | beta <- rep(0, p) 38 | if (sparsity > 0 && snr > 0) { 39 | for (j in 1:sparsity) { 40 | inds <- which(index == j) 41 | beta[inds] <- snr * sqrt(2*log(G)/(n*length(inds))) * sample(c(-1,1), length(inds), replace=T) 42 | } 43 | } 44 | y <- x %*% beta + sigma * rnorm(n) 45 | return(list(x=x, y=y, beta = beta, index=index, sigma = sigma)) 46 | } 47 | -------------------------------------------------------------------------------- /forLater/josh/sim.aicstop.R: -------------------------------------------------------------------------------- 1 | library(intervals) 2 | source("funs.sims.R") 3 | source("../../selectiveInference/R/funs.groupfs.R") 4 | source("../../selectiveInference/R/funs.quadratic.R") 5 | source("../../selectiveInference/R/funs.common.R") 6 | 7 | set.seed(1) 8 | known <- FALSE 9 | niters <- 500 10 | n <- 50 11 | p <- 150 12 | G <- 75 13 | maxsteps <- 10 14 | sparsity <- 4 15 | snr <- 3 16 | rho <- 0 17 | aicstop <- 1 18 | 19 | instance <- function(n, p, G, sparsity, snr, rho, maxsteps, aicstop) { 20 | simd <- randomGaussianFixedP(n, p, G, sparsity, snr, sigma = 1, rho) 21 | x <- simd$x 22 | y <- simd$y 23 | index <- simd$index 24 | if (known) { 25 | fit <- groupfs(x, y, index, maxsteps, sigma = 1, k = 2*log(G), aicstop = aicstop, verbose = T) 26 | } else { 27 | fit <- groupfs(x, y, index, maxsteps, k = 2*log(G), aicstop = aicstop, verbose = T) 28 | } 29 | pvals <- groupfsInf(fit, verbose=T) 30 | return(list(variable = fit$action, pvals = pvals$pv, stopped = attr(fit, "stopped"))) 31 | } 32 | 33 | time <- system.time({ 34 | output <- replicate(niters, instance(n, p, G, sparsity, snr, rho, maxsteps, aicstop)) 35 | }) 36 | 37 | stopped <- do.call(c, list(output[3,])) 38 | pvals <- do.call(c, list(output[2,])) 39 | vars <- do.call(c, list(output[1,])) 40 | 41 | save(pvals, vars, stopped, 42 | file = paste0( 43 | "results/aic", 44 | "_", ifelse(known, "TC", "TF"), 45 | "_n", n, 46 | "_p", p, 47 | "_g", G, 48 | "_rho", gsub(".", "pt", rho, fixed=T), 49 | "_maxsteps", maxsteps, 50 | "_sparsity", sparsity, 51 | "_snr", round(snr), 52 | ".RData")) 53 | 54 | print(time) 55 | -------------------------------------------------------------------------------- /forLater/josh/sim.carve.R: -------------------------------------------------------------------------------- 1 | library(intervals) 2 | source("selectiveInference/R/cv.R") 3 | source("../../selectiveInference/R/funs.groupfs.R") 4 | source("../../selectiveInference/R/funs.quadratic.R") 5 | source("../../selectiveInference/R/funs.common.R") 6 | 7 | set.seed(1) 8 | niters <- 400 9 | known <- FALSE 10 | n <- 100 11 | p <- 50 12 | maxsteps <- 20 13 | sparsity <- 10 14 | snr <- 1 15 | rho <- 0.1 16 | ratio <- 0.75 17 | train <- 1:(ratio*n) 18 | test <- setdiff(1:n, train) 19 | index <- 1:p 20 | nfolds <- 5 21 | 22 | instance <- function(n, p, sparsity, snr, maxsteps, rho) { 23 | 24 | x <- matrix(rnorm(n*p), nrow=n) 25 | if (rho != 0) { 26 | z <- matrix(rep(t(rnorm(n)), p), nrow = n) 27 | x <- sqrt(1-rho)*x + sqrt(rho)*z 28 | } 29 | y <- rnorm(n) 30 | 31 | if (sparsity > 0) { 32 | beta <- rep(0, p) 33 | beta[1:sparsity] <- snr * sample(c(-1,1), sparsity, replace=T) 34 | y <- y + x %*% beta 35 | } 36 | 37 | ytr <- y[train] 38 | xtr <- x[train, ] 39 | yte <- y[test] 40 | xte <- x[test, ] 41 | 42 | if (known) { 43 | trfit <- cvfs(xtr, ytr, maxsteps=maxsteps, sigma = 1, nfolds=nfolds) 44 | fit <- cvfs(x, y, maxsteps=maxsteps, sigma = 1, nfolds=nfolds) 45 | } else { 46 | trfit <- cvfs(xtr, ytr, maxsteps=maxsteps, nfolds=nfolds) 47 | fit <- cvfs(x, y, maxsteps=maxsteps, nfolds=nfolds) 48 | } 49 | 50 | trcols <- which(1:p %in% trfit$action) 51 | tepv <- summary(lm(yte~xte[, trcols]-1))$coefficients[,4] 52 | names(tepv) <- as.character(sort(trfit$action)) 53 | pv <- groupfsInf(fit) 54 | trpv <- groupfsInf(trfit) 55 | return(list(vars = fit$action, pvals = pv$pv, 56 | splitvars = sort(trfit$action), splitpvals = tepv, 57 | trpvals = trpv$pv)) 58 | } 59 | 60 | time <- system.time({ 61 | output <- replicate(niters, instance(n, p, sparsity, snr, maxsteps, rho)) 62 | }) 63 | 64 | vars <- do.call(c, list(output[1,])) 65 | pvals <- do.call(c, list(output[2,])) 66 | splitvars <- do.call(c, list(output[3,])) 67 | splitpvals <- do.call(c, list(output[4,])) 68 | trpvals <- do.call(c, list(output[5,])) 69 | 70 | save(vars, pvals, splitvars, splitpvals, trpvals, 71 | file = paste0("results/carvecv", 72 | "_", ifelse(known, "TC", "TF"), 73 | "_n", n, 74 | "_p", p, 75 | "_rho", gsub(".", "pt", rho, fixed=T), 76 | "_sparsity", sparsity, 77 | "_ratio", gsub(".", "pt", round(ratio, 2), fixed=T), 78 | "_snr", as.character(snr), 79 | ".RData")) 80 | 81 | print(time) 82 | 83 | -------------------------------------------------------------------------------- /forLater/josh/sim.cv.R: -------------------------------------------------------------------------------- 1 | library(intervals) 2 | source("selectiveInference/R/cv.R") 3 | source("../../selectiveInference/R/funs.groupfs.R") 4 | source("../../selectiveInference/R/funs.quadratic.R") 5 | source("../../selectiveInference/R/funs.common.R") 6 | 7 | set.seed(1) 8 | niters <- 50 9 | known <- FALSE 10 | n <- 100 11 | p <- 50 12 | maxsteps <- 8 13 | sparsity <- 5 14 | snr <- 2 15 | rho <- 0.1 16 | nfolds <- 5 17 | 18 | instance <- function(n, p, sparsity, snr, maxsteps, nfolds, rho) { 19 | 20 | x <- matrix(rnorm(n*p), nrow=n) 21 | if (rho != 0) { 22 | z <- matrix(rep(t(rnorm(n)), p), nrow = n) 23 | x <- sqrt(1-rho)*x + sqrt(rho)*z 24 | } 25 | y <- rnorm(n) 26 | 27 | if (sparsity > 0) { 28 | beta <- rep(0, p) 29 | beta[1:sparsity] <- snr * sqrt(2*log(p)/n) * sample(c(-1,1), sparsity, replace=T) 30 | y <- y + x %*% beta 31 | } 32 | 33 | if (known) { 34 | fit <- cvfs(x, y, maxsteps=maxsteps, sigma = 1, nfolds=nfolds) 35 | } else { 36 | fit <- cvfs(x, y, maxsteps=maxsteps, nfolds=nfolds) 37 | } 38 | vars <- fit$action 39 | pvals <- groupfsInf(fit, verbose=T) 40 | fit$cvobj <- NULL 41 | nocvpv <- groupfsInf(fit, verbose=T) 42 | Y <- y - mean(y) 43 | cols <- which(1:p %in% vars) 44 | noselpv <- summary(lm(Y~x[, cols]-1))$coefficients[,4] 45 | names(noselpv) <- as.character(sort(vars)) 46 | return(list(vars = vars, pvals = pvals$pv, 47 | nocvvars = vars, nocvpvals = nocvpv$pv, 48 | noselvars = sort(vars), noselpvals = noselpv)) 49 | } 50 | 51 | time <- system.time({ 52 | output <- replicate(niters, instance(n, p, sparsity, snr, maxsteps, nfolds, rho)) 53 | }) 54 | 55 | vars <- do.call(c, list(output[1,])) 56 | pvals <- do.call(c, list(output[2,])) 57 | nocvvars <- do.call(c, list(output[3,])) 58 | nocvpvals <- do.call(c, list(output[4,])) 59 | noselvars <- do.call(c, list(output[5,])) 60 | noselpvals <- do.call(c, list(output[6,])) 61 | 62 | save(vars, pvals, nocvvars, nocvpvals, noselvars, noselpvals, 63 | file = paste0("results/cv", 64 | "_", ifelse(known, "TC", "TF"), 65 | "_n", n, 66 | "_p", p, 67 | "_rho", gsub(".", "pt", rho, fixed=T), 68 | "_sparsity", sparsity, 69 | "_maxsteps", maxsteps, 70 | "_snr", snr, 71 | ".RData")) 72 | 73 | print(time) 74 | -------------------------------------------------------------------------------- /forLater/josh/sim.cvlar.R: -------------------------------------------------------------------------------- 1 | # Choices 2 | 3 | # RSS: least-squares or penalized beta? 4 | # depends on final model. Go with least-squares for now 5 | 6 | # fixed vs lar? (lar, apparently) 7 | # fixed probably slower, but advantage of same lambda grid? 8 | # is same lambda grid necessary? -- doesn't lar algorithm give all possible models anyway? 9 | # i.e. for non-knot lambda just find where it is in lar path, take corresponding model 10 | 11 | # groups? later 12 | 13 | # TODO 14 | 15 | # copy larInf or groupfsInf? 16 | # larInf: add CV quadratic constraints* & break/fix p-value computation 17 | # -------- *but can we even use the ydecomp we use for quadratic? 18 | # groupfsInf: some ugly rewriting, no cumprojs etc, but straightforward 19 | # -------- downside: need to implement larInf basically 20 | 21 | # larInf 22 | # [ ] is.null(sigma) don't estimate it 23 | 24 | # plan: 25 | # expand Gamma for [-fold] indices? 26 | # stack all the Gammas? or iterate through them? 27 | # work backward from poly.pval <- larInf 28 | 29 | 30 | # big picture / long term 31 | # what OOP kind of design would lend itself to easily implementing more cv things? 32 | 33 | # Gamma: something x n 34 | # Gamma %*% y >= 0 35 | 36 | # pass 0-padded x[-fold] and y[-fold] to lar? 37 | 38 | library(selectiveInference) 39 | setwd("/Users/joftius/Dropbox/work/R-software/forLater/josh") 40 | source("selectiveInference/R/cv.R") 41 | 42 | set.seed(1) 43 | n <- 100 44 | p <- 50 45 | maxsteps <- 10 46 | sparsity <- 3 47 | snr <- 2 48 | rho <- 0.1 49 | nfolds <- 5 50 | 51 | x <- matrix(rnorm(n*p), nrow=n) 52 | y <- rnorm(n) 53 | beta <- rep(0, p) 54 | beta[1:sparsity] <- 2* sqrt(2*log(p)/n) * sample(c(-1,1), sparsity, replace=T) 55 | y <- y + x %*% beta 56 | my <- mean(y) 57 | y <- y - my 58 | 59 | -------------------------------------------------------------------------------- /forLater/josh/sim.datasplit.R: -------------------------------------------------------------------------------- 1 | library(intervals) 2 | source("selectiveInference/R/cv.R") 3 | source("../../selectiveInference/R/funs.groupfs.R") 4 | source("../../selectiveInference/R/funs.quadratic.R") 5 | source("../../selectiveInference/R/funs.common.R") 6 | 7 | set.seed(19) 8 | niters <- 500 9 | known <- FALSE 10 | n <- 50 11 | p <- 100 12 | maxsteps <- 8 13 | sparsity <- 5 14 | snr <- 2 15 | rho <- 0.1 16 | ratio <- 0.6 17 | ratio2 <- 0.8 18 | train <- 1:(ratio*n) 19 | test <- setdiff(1:n, train) 20 | train2 <- 1:(ratio2*n) 21 | test2 <- setdiff(1:n, train2) 22 | index <- 1:p 23 | 24 | x <- matrix(rnorm(n*p), nrow=n) 25 | if (rho != 0) { 26 | z <- matrix(rep(t(rnorm(n)), p), nrow = n) 27 | x <- sqrt(1-rho)*x + sqrt(rho)*z 28 | } 29 | 30 | instance <- function(n, p, sparsity, snr, maxsteps, rho) { 31 | 32 | y <- rnorm(n) 33 | 34 | if (sparsity > 0) { 35 | beta <- rep(0, p) 36 | beta[1:sparsity] <- snr * sample(c(-1,1), sparsity, replace=T) 37 | y <- y + x %*% beta 38 | } 39 | 40 | ytr <- y[train] 41 | xtr <- x[train, ] 42 | yte <- y[test] 43 | xte <- x[test, ] 44 | 45 | ytr2 <- y[train2] 46 | xtr2 <- x[train2, ] 47 | yte2 <- y[test2] 48 | xte2 <- x[test2, ] 49 | 50 | if (known) { 51 | trfit <- groupfs(xtr, ytr, index, maxsteps=maxsteps, sigma=1, aicstop=1, k = log(length(train))) 52 | fit <- groupfs(xtr2, ytr2, index, maxsteps=maxsteps, sigma=1, aicstop=1, k = log(length(train2))) 53 | } else { 54 | trfit <- groupfs(xtr, ytr, index, maxsteps=maxsteps, aicstop=1, k = 2*log(p)) 55 | fit <- groupfs(xtr2, ytr2, index, maxsteps=maxsteps, aicstop=1, k = 2*log(p)) 56 | } 57 | 58 | trcols <- which(1:p %in% trfit$action) 59 | tr2cols <- which(1:p %in% fit$action) 60 | tepv <- summary(lm(yte~xte[, trcols]-1))$coefficients[,4] 61 | tepv2 <- summary(lm(yte2~xte2[, tr2cols]-1))$coefficients[,4] 62 | names(tepv) <- as.character(sort(trfit$action)) 63 | names(tepv2) <- as.character(sort(fit$action)) 64 | pv <- groupfsInf(fit) 65 | trpv <- groupfsInf(trfit) 66 | return(list(vars = fit$action, pvals = pv$pv, 67 | splitvars = sort(trfit$action), splitpvals = tepv, 68 | splitvars2 = sort(fit$action), splitpvals2 = tepv2, 69 | trpvals = trpv$pv)) 70 | } 71 | 72 | time <- system.time({ 73 | output <- replicate(niters, instance(n, p, sparsity, snr, maxsteps, rho)) 74 | }) 75 | 76 | vars <- do.call(c, list(output[1,])) 77 | pvals <- do.call(c, list(output[2,])) 78 | splitvars <- do.call(c, list(output[3,])) 79 | splitpvals <- do.call(c, list(output[4,])) 80 | splitvars2 <- do.call(c, list(output[5,])) 81 | splitpvals2 <- do.call(c, list(output[6,])) 82 | trpvals <- do.call(c, list(output[7,])) 83 | 84 | save(vars, pvals, splitvars, splitpvals, 85 | splitvars2, splitpvals2, trpvals, 86 | file = paste0("results/datasplit", 87 | "_", ifelse(known, "TC", "TF"), 88 | "_n", n, 89 | "_p", p, 90 | "_rho", gsub(".", "pt", rho, fixed=T), 91 | "_sparsity", sparsity, 92 | "_ratio", gsub(".", "pt", round(ratio, 2), fixed=T), 93 | "_snr", as.character(snr), 94 | "_bic.RData")) 95 | 96 | print(time) 97 | 98 | -------------------------------------------------------------------------------- /forLater/josh/sim.groupfs.R: -------------------------------------------------------------------------------- 1 | library(intervals) 2 | source("funs.sims.R") 3 | #source("selectiveInference/R/cv.R") 4 | source("../../selectiveInference/R/funs.groupfs.R") 5 | source("../../selectiveInference/R/funs.quadratic.R") 6 | source("../../selectiveInference/R/funs.common.R") 7 | 8 | set.seed(1) 9 | known <- TRUE 10 | niters <- 300 11 | n <- 50 12 | p <- 150 13 | G <- 75 14 | maxsteps <- 8 15 | sparsity <- 4 16 | snr <- 2 17 | rho <- 0 18 | 19 | instance <- function(n, p, G, sparsity, snr, rho, maxsteps) { 20 | simd <- randomGaussianFixedP(n, p, G, sparsity, snr, sigma = 1, rho) 21 | x <- simd$x 22 | y <- simd$y 23 | index <- simd$index 24 | if (known) { 25 | fit <- groupfs(x, y, index, maxsteps, sigma = 1, k = log(n)) 26 | } else { 27 | fit <- groupfs(x, y, index, maxsteps, k = log(n)) 28 | } 29 | pvals <- groupfsInf(fit, verbose=T) 30 | return(list(variable = fit$action, pvals = pvals$pv)) 31 | } 32 | 33 | time <- system.time({ 34 | output <- replicate(niters, instance(n, p, G, sparsity, snr, rho, maxsteps)) 35 | }) 36 | 37 | pvals <- do.call(c, list(output[2,])) 38 | vars <- do.call(c, list(output[1,])) 39 | 40 | save(pvals, vars, 41 | file = paste0("results/", 42 | ifelse(known, "TC", "TF"), 43 | "_n", n, 44 | "_p", p, 45 | "_g", G, 46 | "_rho", gsub(".", "pt", rho, fixed=T), 47 | "_maxsteps", maxsteps, 48 | "_sparsity", sparsity, 49 | "_snr", round(snr), 50 | ".RData")) 51 | 52 | print(time) 53 | -------------------------------------------------------------------------------- /forLater/josh/sim.selectedmodel.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | library(intervals) 3 | setwd("~/Dropbox/work/R-software/forLater/josh") 4 | source("selectiveInference/R/cv.R") 5 | source("../../selectiveInference/R/funs.groupfs.R") 6 | source("../../selectiveInference/R/funs.quadratic.R") 7 | source("../../selectiveInference/R/funs.common.R") 8 | source("../../selectiveInference/R/funs.fs.R") 9 | source("../../selectiveInference/R/funs.lar.R") 10 | source("../../selectiveInference/R/funs.inf.R") 11 | library(MASS) 12 | pinv = ginv 13 | 14 | set.seed(19) 15 | niters <- 500 16 | known <- TRUE 17 | n <- 50 18 | p <- 100 19 | maxsteps <- 8 20 | sparsity <- 5 21 | snr <- 2 22 | index <- 1:p 23 | 24 | x <- matrix(rnorm(n*p), nrow=n) 25 | 26 | instance <- function(n, p, sparsity, snr, maxsteps) { 27 | y <- rnorm(n) 28 | if (sparsity > 0) { 29 | beta <- rep(0, p) 30 | beta[1:sparsity] <- snr * sample(c(-1,1), sparsity, replace=T) 31 | y <- y + x %*% beta 32 | } 33 | y <- y - mean(y) 34 | fit <- groupfs(x, y, index, maxsteps=maxsteps, sigma=1, intercept=F, center=F, normalize=F) 35 | fitfs <- fs(x, y, maxsteps=maxsteps, intercept=F, normalize=F) 36 | if (any(fit$action != fitfs$action)) stop("Model paths did not agree") 37 | pvfs <- fsInf(fitfs, sigma=1, k = maxsteps, type = "all") 38 | pv <- groupfsInf(fit) 39 | return(list(vars = fit$action, pvals = pv$pv, selpvals = pvfs$pv)) 40 | } 41 | 42 | time <- system.time({ 43 | output <- replicate(niters, instance(n, p, sparsity, snr, maxsteps)) 44 | }) 45 | 46 | vars <- do.call(c, list(output[1,])) 47 | pvals <- do.call(c, list(output[2,])) 48 | selpvals <- do.call(c, list(output[3,])) 49 | 50 | save(vars, pvals, selpvals, 51 | file = paste0("results/selected", 52 | "_", ifelse(known, "TC", "TF"), 53 | "_n", n, 54 | "_p", p, 55 | "_sparsity", sparsity, 56 | "_snr", as.character(snr), 57 | ".RData")) 58 | 59 | print(time) 60 | 61 | -------------------------------------------------------------------------------- /forLater/josh/sim.splitcv.R: -------------------------------------------------------------------------------- 1 | library(intervals) 2 | source("selectiveInference/R/cv.R") 3 | source("../../selectiveInference/R/funs.groupfs.R") 4 | source("../../selectiveInference/R/funs.quadratic.R") 5 | source("../../selectiveInference/R/funs.common.R") 6 | 7 | set.seed(1) 8 | niters <- 500 9 | known <- FALSE 10 | n <- 100 11 | p <- 200 12 | maxsteps <- 20 13 | sparsity <- 5 14 | snr <- 1 15 | rho <- 0.1 16 | ratio <- 0.75 17 | train <- 1:(ratio*n) 18 | test <- setdiff(1:n, train) 19 | index <- 1:p 20 | 21 | instance <- function(n, p, sparsity, snr, maxsteps, rho) { 22 | 23 | x <- matrix(rnorm(n*p), nrow=n) 24 | if (rho != 0) { 25 | z <- matrix(rep(t(rnorm(n)), p), nrow = n) 26 | x <- sqrt(1-rho)*x + sqrt(rho)*z 27 | } 28 | y <- rnorm(n) 29 | 30 | if (sparsity > 0) { 31 | beta <- rep(0, p) 32 | beta[1:sparsity] <- snr * sample(c(-1,1), sparsity, replace=T) 33 | y <- y + x %*% beta 34 | } 35 | 36 | ytr <- y[train] 37 | xtr <- x[train, ] 38 | yte <- y[test] 39 | xte <- x[test, ] 40 | 41 | if (known) { 42 | trfit <- groupfs(xtr, ytr, index, maxsteps=maxsteps, sigma=1, aicstop=1, k = 2*log(p)) 43 | fit <- groupfs(x, y, index, maxsteps=maxsteps, sigma=1, aicstop=1, k = 2*log(p)) 44 | } else { 45 | trfit <- groupfs(xtr, ytr, index, maxsteps=maxsteps, aicstop=1, k = log(length(train))) 46 | fit <- groupfs(x, y, index, maxsteps=maxsteps, aicstop=1, k = log(n)) 47 | } 48 | 49 | trcols <- which(1:p %in% trfit$action) 50 | tepv <- summary(lm(yte~xte[, trcols]-1))$coefficients[,4] 51 | names(tepv) <- as.character(sort(trfit$action)) 52 | # pv <- groupfsInf(fit) 53 | # trpv <- groupfsInf(trfit) 54 | return(list(vars = fit$action, splitvars = sort(trfit$action), splitpvals = tepv)) 55 | } 56 | 57 | time <- system.time({ 58 | output <- replicate(niters, instance(n, p, sparsity, snr, maxsteps, rho)) 59 | }) 60 | 61 | vars <- do.call(c, list(output[1,])) 62 | splitvars <- do.call(c, list(output[2,])) 63 | splitpvals <- do.call(c, list(output[3,])) 64 | 65 | save(vars, pvals, splitvars, splitpvals, trpvals, 66 | file = paste0("results/datasplit", 67 | "_", ifelse(known, "TC", "TF"), 68 | "_n", n, 69 | "_p", p, 70 | "_rho", gsub(".", "pt", rho, fixed=T), 71 | "_sparsity", sparsity, 72 | "_ratio", gsub(".", "pt", round(ratio, 2), fixed=T), 73 | "_snr", as.character(snr), 74 | "_bic.RData")) 75 | 76 | print(time) 77 | 78 | -------------------------------------------------------------------------------- /forLater/josh/tests/test.cv.R: -------------------------------------------------------------------------------- 1 | library(intervals) 2 | source("../selectiveInference/R/cv.R") 3 | source("../../../selectiveInference/R/funs.groupfs.R") 4 | source("../../../selectiveInference/R/funs.quadratic.R") 5 | source("../../../selectiveInference/R/funs.common.R") 6 | 7 | set.seed(1) 8 | n <- 50 9 | p <- 100 10 | maxsteps <- 10 11 | sparsity <- 5 12 | snr <- 1 13 | nfolds <- 5 14 | x <- matrix(rnorm(n*p), nrow=n) 15 | y <- rnorm(n) 16 | beta <- rep(0, p) 17 | beta[1:sparsity] <- snr * sample(c(-1,1), sparsity, replace=T) 18 | y <- y + x %*% beta 19 | fit <- cvfs(x, y, maxsteps=maxsteps, nfolds=nfolds) 20 | pvals <- groupfsInf(fit, verbose=T) 21 | 22 | -------------------------------------------------------------------------------- /forLater/maxZ/forLater: -------------------------------------------------------------------------------- 1 | \name{fsInf_maxZ} 2 | \alias{fsInf_maxZ} 3 | \title{ 4 | Selective inference for forward stepwise regression 5 | } 6 | \description{ 7 | Computes maxZ selective p-values and confidence intervals for forward 8 | stepwise regression 9 | } 10 | \usage{ 11 | 12 | fsInf_maxZ(obj, sigma=NULL, alpha=0.1, k=NULL, ndraw=8000, burnin=2000,verbose=FALSE) 13 | 14 | } 15 | 16 | \arguments{ 17 | \item{obj}{ 18 | Object returned by \code{\link{fs}} function 19 | } 20 | \item{sigma}{ 21 | Estimate of error standard deviation. If NULL (default), this is estimated 22 | using the mean squared residual of the full least squares fit when n >= 2p, and 23 | using the standard deviation of y when n < 2p. In the latter case, the user 24 | should use \code{\link{estimateSigma}} function for a more accurate estimate 25 | } 26 | \item{alpha}{ 27 | Significance level for confidence intervals (target is miscoverage alpha/2 in each tail) 28 | } 29 | \item{k}{ 30 | See "type" argument below. Default is NULL, in which case k is taken to be the 31 | the number of steps computed in the forward stepwise path 32 | } 33 | \item{ndraw}{Number of Monte Carlo samples generated} 34 | \item{burnin}{ 35 | Number of samples discarded at the beginning of the chain 36 | } 37 | \item{verbose}{Print out progress along the way? Default is FALSE} 38 | } 39 | 40 | \details{ 41 | This function computes selective maxZ p-values 42 | for forward stepwise regression. These p-values are independent the under null, 43 | so that stopping via the forwardStop rule yields guaranteed FDR control 44 | } 45 | 46 | \value{ 47 | \item{pv}{P-values for each model in the sequence} 48 | \item{k}{Value of k specified in call} 49 | \item{khat}{When type is "active", this is an estimated stopping point 50 | declared by \code{\link{forwardStop}}} 51 | \item{sigma}{Value of error standard deviation (sigma) used} 52 | \item{vars}{Variables in active set} 53 | \item{sign}{Signs of active coefficients} 54 | \item{alpha}{Desired coverage (alpha/2 in each tail)} 55 | \item{realized_maxZ}{Value of maxZ statistic computed at each step} 56 | \item{call}{The call to fsInf_maxZ} 57 | } 58 | 59 | \references{ 60 | Will Fithian, Jonathan Taylor, Ryan Tibshirani, and Rob Tibshirani (2015). 61 | Selective sequential model selection. arXiv:1512.02565.. 62 | 63 | 64 | } 65 | 66 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 67 | 68 | \seealso{\code{\link{fs}}} 69 | 70 | \examples{ 71 | set.seed(33) 72 | n = 50 73 | p = 10 74 | sigma = 1 75 | x = matrix(rnorm(n*p),n,p) 76 | beta = c(3,2,rep(0,p-2)) 77 | y = x\%*\%beta + sigma*rnorm(n) 78 | 79 | # run forward stepwise 80 | fsfit = fs(x,y) 81 | 82 | # compute sequential p-values a 83 | # (sigma estimated from full model) 84 | out.seq = fsInf_maxZ(fsfit) 85 | out.seq 86 | } 87 | -------------------------------------------------------------------------------- /forLater/yuval/test_sampler.R: -------------------------------------------------------------------------------- 1 | 2 | # The following code runs 4 tests on the sample_truncnorm sampler (sample_truncnorm.R). 3 | # 4 | # For each of these runs, we compare the sample-mean to the approximated sample mean 5 | # based on the moments function (mtmvtnorm) of the tmvtnorm package. Scenarios 1 through 4 use d=5, 6 | # whereas scenario 5 checks that the code does not break for scalars. 7 | # 8 | # The scenarios are: 9 | # 1) Identity sigma, mu = 0, only lower bound 10 | # 2) Colored sigma, mu = 0, only lower bound 11 | # 3) Colored sigma, mu = 0, lower bound x_2,x_3,x_4 upper bound x_1,x_5 12 | # 4) Colored sigma, mu >= 0, lower bound x_2,x_3,x_4 upper bound x_1,x_5 13 | # 5) sigma = 2, mu = 1, lower bound = 2 14 | 15 | library(tmvtnorm) 16 | 17 | #### Scenario 1: 18 | # IID reference with mu = 0 19 | SigmaIid = diag(5) 20 | constr = thresh2constraints(5, lower = 2) 21 | 22 | sample_1 = sample_truncnorm(ndraw = 1000,A= constr$A,b = constr$b, Sigma = SigmaIid, initial = rep(2.1,5), 23 | eta = rep(1,5),thinning = 500, how_often = 100) 24 | 25 | exp_mean_1 = mtmvnorm( sigma = SigmaIid, mean = rep(0,5), lower = rep(2,5))$tmean 26 | rms_err_1 = sqrt(mean((colMeans(sample_1) - exp_mean_1)^2)) 27 | cat(rms_err_1) 28 | 29 | stopifnot(rms_err_1< 0.03 ) 30 | 31 | #### Scenario 2: 32 | # Colored reference with mu = 0 33 | SigmaCol = diag(5) 34 | for (k in 1:4) {SigmaCol[k,k+1] = 0.3; SigmaCol[k+1,k] = 0.3} 35 | SigmaCol[1,2] = SigmaCol[1,2] = SigmaCol[1,2] =SigmaCol[1,2] 36 | 37 | sample_2 = sample_truncnorm(ndraw = 1000,A= constr$A,b = constr$b, Sigma = SigmaCol, initial = rep(2.1,5), 38 | eta = rep(1,5),thinning = 100, how_often = 100) 39 | 40 | exp_mean_2 = mtmvnorm( sigma = SigmaCol, mean = rep(0,5), lower = rep(2,5))$tmean 41 | rms_err_2 = sqrt(mean((colMeans(sample_2) - exp_mean_2)^2)) 42 | cat(rms_err_2) 43 | 44 | stopifnot(rms_err_2< 0.03 ) 45 | 46 | 47 | 48 | #### Scenario 3: 49 | # Colored reference with tied-down bump 50 | constr_tied = thresh2constraints(5, lower =c(-Inf, 2,2,2, -Inf), upper = c(2, Inf,Inf,Inf,2) ) 51 | sample_3 = sample_truncnorm(ndraw = 1500,A= constr_tied$A,b = constr_tied$b, Sigma = SigmaCol, initial = 2+ c(-0.1,0.1,0.1,0.1,-0.1), 52 | eta = c(0,1,1,1,0),thinning = 100, how_often = 100) 53 | 54 | exp_mean_3 = mtmvnorm( sigma = SigmaCol, mean = rep(0,5), lower =c(-Inf, 2,2,2, -Inf), upper = c(2, Inf,Inf,Inf,2) )$tmean 55 | rms_err_3 = sqrt(mean((colMeans(sample_3) - exp_mean_3)^2)) 56 | cat(rms_err_3) 57 | 58 | stopifnot(rms_err_3< 0.03 ) 59 | 60 | 61 | #### Scenario 4: 62 | # Colored reference with tied-down bump and non-zero mean 63 | constr_tied = thresh2constraints(5, lower =c(-Inf, 2,2,2, -Inf), upper = c(2, Inf,Inf,Inf,2) ) 64 | mu_vec = c(0,1,1,0.5,0) 65 | sample_4 = sample_truncnorm(ndraw = 1500,A= constr_tied$A,b = constr_tied$b, Sigma = SigmaCol, mu = mu_vec, initial = 2+ c(-0.1,0.1,0.1,0.1,-0.1), 66 | eta = c(0,1,1,1,0),thinning = 100, how_often = 100) 67 | 68 | exp_mean_4 = mtmvnorm( sigma = SigmaCol, mean = mu_vec, lower =c(-Inf, 2,2,2, -Inf), upper = c(2, Inf,Inf,Inf,2) )$tmean 69 | rms_err_4 = sqrt(mean((colMeans(sample_4) - exp_mean_4)^2)) 70 | cat(rms_err_4) 71 | 72 | stopifnot(rms_err_4< 0.03 ) 73 | 74 | 75 | #### Scenario 5: 76 | sigma = 2 # The variance 77 | mu = 1 78 | lower_bound = 2 79 | constr_1d = thresh2constraints(1, lower = lower_bound) 80 | sample_5 = sample_truncnorm(ndraw = 2500,A= constr_1d$A,b = constr_1d$b, Sigma = sigma, mu = mu, initial = 2.1, 81 | eta = 1,thinning = 10, how_often = 100) 82 | 83 | exp_mean_5 = mtmvnorm( sigma = sigma, mean = mu, lower = lower_bound)$tmean 84 | rms_err_5 = abs(mean(sample_5) - exp_mean_5) 85 | cat(rms_err_5) 86 | 87 | stopifnot(rms_err_5< 0.03 ) 88 | 89 | -------------------------------------------------------------------------------- /selectiveInference/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: selectiveInference 2 | Type: Package 3 | Title: Tools for Post-Selection Inference 4 | Version: 1.2.5 5 | Date: 2019-09-04 6 | Author: Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, 7 | Joshua Loftus, Stephen Reid, Jelena Markovic 8 | Maintainer: Rob Tibshirani 9 | Depends: 10 | glmnet, 11 | intervals, 12 | survival, 13 | adaptMCMC, 14 | MASS 15 | Suggests: 16 | Rmpfr 17 | Description: New tools for post-selection inference, for use with forward 18 | stepwise regression, least angle regression, the lasso, and the many means 19 | problem. The lasso function implements Gaussian, logistic and Cox survival 20 | models. 21 | License: GPL-2 22 | RoxygenNote: 5.0.1 23 | LinkingTo: Rcpp 24 | Imports: Rcpp 25 | -------------------------------------------------------------------------------- /selectiveInference/NAMESPACE: -------------------------------------------------------------------------------- 1 | export(lar, 2 | fs, 3 | larInf, 4 | fsInf, 5 | coef.lar, 6 | coef.fs, 7 | predict.lar, 8 | predict.fs, 9 | print.lar, 10 | print.fs, 11 | print.larInf, 12 | print.fsInf, 13 | plot.lar, 14 | plot.fs, 15 | fixedLassoInf, 16 | print.fixedLassoInf, 17 | forwardStop, 18 | estimateSigma, 19 | manyMeans, 20 | print.manyMeans, 21 | groupfs, 22 | groupfsInf, 23 | scaleGroups, 24 | factorDesign, 25 | TG.pvalue, 26 | TG.limits, 27 | TG.interval, 28 | debiasingMatrix, 29 | randomizedLasso, 30 | randomizedLassoInf, 31 | ROSI, 32 | print.ROSI 33 | ) 34 | 35 | S3method("coef", "lar") 36 | S3method("predict", "lar") 37 | S3method("print", "lar") 38 | S3method("plot", "lar") 39 | S3method("print", "larInf") 40 | S3method("coef", "fs") 41 | S3method("predict", "fs") 42 | S3method("print", "fs") 43 | S3method("plot", "fs") 44 | S3method("print", "fsInf") 45 | S3method("print", "fixedLassoInf") 46 | S3method("print", "ROSI") 47 | S3method("print", "fixedLogitLassoInf") 48 | S3method("print", "fixedCoxLassoInf") 49 | S3method("print", "manyMeans") 50 | S3method("print", "groupfs") 51 | S3method("print", "groupfsInf") 52 | 53 | useDynLib("selectiveInference") 54 | import(glmnet) 55 | import(intervals) 56 | import(survival) 57 | importFrom("graphics", abline, axis, matplot) 58 | importFrom("stats", dnorm, lsfit, pexp, pnorm, predict, 59 | qnorm, rnorm, sd, uniroot, dchisq, model.matrix, pchisq, resid, binomial, fitted, 60 | p.adjust, sigma) 61 | importFrom("stats", "coef", "df", "lm", "pf") 62 | importFrom("stats", "glm", "residuals", "vcov") 63 | importFrom("stats", "rbinom", "rexp") 64 | importFrom("Rcpp", "sourceCpp") 65 | importFrom("adaptMCMC", "MCMC") 66 | importFrom("MASS","mvrnorm") 67 | -------------------------------------------------------------------------------- /selectiveInference/R/funs.ROSI.side.R: -------------------------------------------------------------------------------- 1 | 2 | estimate_sigma_data_spliting = function(X,y, verbose=FALSE){ 3 | nrep = 20 4 | sigma_est = 0 5 | nest = 0 6 | for (i in 1:nrep){ 7 | n=nrow(X) 8 | m=floor(n/2) 9 | subsample = sample(1:n, m, replace=FALSE) 10 | leftover = setdiff(1:n, subsample) 11 | CV = cv.glmnet(X[subsample,], y[subsample], standardize=FALSE, intercept=FALSE, family="gaussian") 12 | beta_hat = coef(CV, s="lambda.min")[-1] 13 | selected = which(beta_hat!=0) 14 | if (verbose){ 15 | print(c("nselected",length(selected))) 16 | } 17 | if (length(selected)>0){ 18 | LM = lm(y[leftover]~X[leftover,][,selected]) 19 | sigma_est = sigma_est+sigma(LM) 20 | nest = nest+1 21 | } 22 | } 23 | return(sigma_est/nest) 24 | } 25 | 26 | selective.plus.BH = function(beta, selected.vars, pvalues, q, verbose=FALSE){ 27 | 28 | if (is.null(selected.vars)){ 29 | return(list(power=NA, FDR=NA, pvalues=NULL, null.pvalues=NULL, ci=NULL, nselected=0)) 30 | } 31 | 32 | nselected = length(selected.vars) 33 | p.adjust.BH = p.adjust(pvalues, method = "BH", n = nselected) 34 | rejected = selected.vars[which(p.adjust.BH0){ 66 | null.pvalues = pvalues[selected.nulls] 67 | if (verbose){ 68 | print(paste("selected nulls", length(selected.nulls), "vars:",toString(selected.vars[selected.nulls]))) 69 | } 70 | } 71 | 72 | return(list(power=power, 73 | FDR=FDR, 74 | pvalues=pvalues, 75 | null.pvalues=null.pvalues, 76 | nselected=nselected, 77 | nrejected=nrejected)) 78 | } 79 | 80 | 81 | AR_design = function(n, p, rho, scale=FALSE){ 82 | times = c(1:p) 83 | cov_mat <- rho^abs(outer(times, times, "-")) 84 | chol_mat = chol(cov_mat) # t(chol_mat) %*% chol_mat = cov_mat 85 | X=matrix(rnorm(n*p), nrow=n) %*% t(chol_mat) 86 | if (scale==TRUE){ 87 | X = scale(X) 88 | X = X/sqrt(n) 89 | } 90 | return(X) 91 | } 92 | 93 | 94 | equicorrelated_design = function(n, p, rho, scale=FALSE){ 95 | X = sqrt(1-rho)*matrix(rnorm(n*p),n) + sqrt(rho)*matrix(rep(rnorm(n), p), nrow = n) 96 | if (scale==TRUE){ 97 | X = scale(X) 98 | X = X/sqrt(n) 99 | } 100 | return(X) 101 | } 102 | 103 | gaussian_instance = function(n, p, s, rho, sigma, snr, random_signs=TRUE, scale=FALSE, design="AR"){ 104 | 105 | if (design=="AR"){ 106 | X=AR_design(n,p,rho, scale) 107 | } else if (design=="equicorrelated"){ 108 | X=equicorrelated_design(n,p, rho, scale) 109 | } 110 | 111 | beta = rep(0, p) 112 | beta[1:s]=snr 113 | 114 | if (random_signs==TRUE && s>0){ 115 | signs = sample(c(-1,1), s, replace = TRUE) 116 | beta[1:s] = beta[1:s] * signs 117 | } 118 | 119 | beta=sample(beta) 120 | y = X %*% beta + rnorm(n)*sigma 121 | result <- list(X=X,y=y,beta=beta) 122 | return(result) 123 | } 124 | 125 | logistic_instance = function(n, p, s, rho, snr, random_signs=TRUE, scale=FALSE, design="AR"){ 126 | 127 | if (design=="AR"){ 128 | X=AR_design(n,p,rho, scale) 129 | } else if (design=="equicorrelated"){ 130 | X=equicorrelated_design(n,p, rho, scale) 131 | } 132 | 133 | beta = rep(0, p) 134 | beta[1:s]=snr 135 | if (random_signs==TRUE && s>0){ 136 | signs = sample(c(-1,1), s, replace = TRUE) 137 | beta[1:s] = beta[1:s] * signs 138 | } 139 | beta=sample(beta) 140 | mu = X %*% beta 141 | prob = exp(mu)/(1+exp(mu)) 142 | y = rbinom(n, 1, prob) 143 | 144 | result <- list(X=X,y=y,beta=beta) 145 | return(result) 146 | } 147 | 148 | 149 | estimate_sigma = function(X, y, beta_hat_cv){ 150 | n=nrow(X) 151 | p=ncol(X) 152 | if (n=0)) 24 | } 25 | 26 | ############################## 27 | 28 | # Centering and scaling convenience function 29 | 30 | standardize <- function(x, y, intercept, normalize) { 31 | x = as.matrix(x) 32 | y = as.numeric(y) 33 | n = nrow(x) 34 | p = ncol(x) 35 | 36 | if (intercept) { 37 | bx = colMeans(x) 38 | by = mean(y) 39 | x = scale(x,bx,FALSE) 40 | y = y-mean(y) 41 | } else { 42 | bx = rep(0,p) 43 | by = 0 44 | } 45 | if (normalize) { 46 | sx = sqrt(colSums(x^2)) 47 | x = scale(x,FALSE,sx) 48 | } else { 49 | sx = rep(1,p) 50 | } 51 | 52 | return(list(x=x,y=y,bx=bx,by=by,sx=sx)) 53 | } 54 | 55 | ############################## 56 | 57 | # Interpolation function to get coefficients 58 | 59 | coef.interpolate <- function(beta, s, knots, decreasing=TRUE) { 60 | # Sort the s values 61 | o = order(s,decreasing=decreasing) 62 | s = s[o] 63 | 64 | k = length(s) 65 | mat = matrix(rep(knots,each=k),nrow=k) 66 | if (decreasing) b = s >= mat 67 | else b = s <= mat 68 | blo = max.col(b,ties.method="first") 69 | bhi = pmax(blo-1,1) 70 | 71 | i = bhi==blo 72 | p = numeric(k) 73 | p[i] = 0 74 | p[!i] = ((s-knots[blo])/(knots[bhi]-knots[blo]))[!i] 75 | 76 | beta = t((1-p)*t(beta[,blo,drop=FALSE]) + p*t(beta[,bhi,drop=FALSE])) 77 | colnames(beta) = as.character(round(s,3)) 78 | rownames(beta) = NULL 79 | 80 | # Return in original order 81 | o = order(o) 82 | return(beta[,o,drop=FALSE]) 83 | } 84 | 85 | ############################## 86 | 87 | checkargs.xy <- function(x, y) { 88 | if (missing(x)) stop("x is missing") 89 | if (is.null(x) || !is.matrix(x)) stop("x must be a matrix") 90 | if (missing(y)) stop("y is missing") 91 | if (is.null(y) || !is.numeric(y)) stop("y must be numeric") 92 | if (ncol(x) == 0) stop("There must be at least one predictor [must have ncol(x) > 0]") 93 | if (checkcols(x)) stop("x cannot have duplicate columns") 94 | if (length(y) == 0) stop("There must be at least one data point [must have length(y) > 0]") 95 | if (length(y)!=nrow(x)) stop("Dimensions don't match [length(y) != nrow(x)]") 96 | } 97 | 98 | checkargs.misc <- function(sigma=NULL, alpha=NULL, k=NULL, 99 | gridrange=NULL, gridpts=NULL, griddepth=NULL, 100 | mult=NULL, ntimes=NULL, 101 | beta=NULL, lambda=NULL, tol.beta=NULL, tol.kkt=NULL, 102 | bh.q=NULL) { 103 | 104 | if (!is.null(sigma) && sigma <= 0) stop("sigma must be > 0") 105 | if (!is.null(lambda) && lambda < 0) stop("lambda must be >= 0") 106 | if (!is.null(alpha) && (alpha <= 0 || alpha >= 1)) stop("alpha must be between 0 and 1") 107 | if (!is.null(k) && length(k) != 1) stop("k must be a single number") 108 | if (!is.null(k) && (k < 1 || k != floor(k))) stop("k must be an integer >= 1") 109 | if (!is.null(gridrange) && (length(gridrange) != 2 || gridrange[1] > gridrange[2])) 110 | stop("gridrange must be an interval of the form c(a,b) with a <= b") 111 | if (!is.null(gridpts) && (gridpts < 20 || gridpts != round(gridpts))) 112 | stop("gridpts must be an integer >= 20") 113 | if (!is.null(griddepth) && (griddepth > 10 || griddepth != round(griddepth))) 114 | stop("griddepth must be an integer <= 10") 115 | if (!is.null(mult) && mult < 0) stop("mult must be >= 0") 116 | if (!is.null(ntimes) && (ntimes <= 0 || ntimes != round(ntimes))) 117 | stop("ntimes must be an integer > 0") 118 | if (!is.null(beta) && sum(beta!=0)==0) stop("Value of lambda too large, beta is zero") 119 | if (!is.null(lambda) && length(lambda) != 1) stop("lambda must be a single number") 120 | if (!is.null(lambda) && lambda < 0) stop("lambda must be >=0") 121 | if (!is.null(tol.beta) && tol.beta <= 0) stop("tol.beta must be > 0") 122 | if (!is.null(tol.kkt) && tol.kkt <= 0) stop("tol.kkt must be > 0") 123 | } 124 | 125 | # Make sure that no two columms of A are the same 126 | # (this works with probability one). 127 | 128 | checkcols <- function(A) { 129 | b = rnorm(nrow(A)) 130 | a = sort(t(A)%*%b) 131 | if (any(diff(a)==0)) return(TRUE) 132 | return(FALSE) 133 | } 134 | 135 | estimateSigma <- function(x, y, intercept=TRUE, standardize=TRUE) { 136 | checkargs.xy(x,rep(0,nrow(x))) 137 | if(nrow(x)<10) stop("Number of observations must be at least 10 to run estimateSigma") 138 | cvfit=cv.glmnet(x,y,intercept=intercept,standardize=standardize) 139 | lamhat=cvfit$lambda.min 140 | fit=glmnet(x,y,standardize=standardize) 141 | yhat=predict(fit,x,s=lamhat) 142 | nz=sum(predict(fit,s=lamhat, type="coef")!=0) 143 | sigma=sqrt(sum((y-yhat)^2)/(length(y)-nz-1)) 144 | return(list(sigmahat=sigma, df=nz)) 145 | } 146 | 147 | # Update the QR factorization, after a column has been 148 | # added. Here Q1 is m x n, Q2 is m x k, and R is n x n. 149 | 150 | updateQR <- function(Q1,Q2,R,col) { 151 | m = nrow(Q1) 152 | n = ncol(Q1) 153 | k = ncol(Q2) 154 | 155 | a = update1_(as.matrix(Q2), t(Q2)%*%col, m, k) # Rcpp call 156 | 157 | Q2 = matrix(a$Q2,nrow=m) 158 | w = c(t(Q1)%*%col,a$w) 159 | 160 | # Re-structure: delete a column from Q2, add one to 161 | # Q1, and expand R 162 | Q1 = cbind(Q1,Q2[,1]) 163 | Q2 = Q2[,-1,drop=FALSE] 164 | R = rbind(R,rep(0,n)) 165 | R = cbind(R,w[Seq(1,n+1)]) 166 | 167 | return(list(Q1=Q1,Q2=Q2,R=R)) 168 | } 169 | 170 | # Moore-Penrose pseudo inverse for symmetric matrices 171 | 172 | pinv <- function(A, tol=.Machine$double.eps) { 173 | e = eigen(A) 174 | v = Re(e$vec) 175 | d = Re(e$val) 176 | d[d > tol] = 1/d[d > tol] 177 | d[d < tol] = 0 178 | if (length(d)==1) return(v*d*v) 179 | else return(v %*% diag(d) %*% t(v)) 180 | } 181 | -------------------------------------------------------------------------------- /selectiveInference/R/funs.fixedCox.R: -------------------------------------------------------------------------------- 1 | fixedCoxLassoInf=function(x, y, status, 2 | beta, lambda, 3 | alpha=.1, type=c("partial"), 4 | tol.beta=1e-5, tol.kkt=0.1, 5 | gridrange=c(-100,100), 6 | bits=NULL, verbose=FALSE, 7 | this.call=NULL){ 8 | 9 | checkargs.xy(x,y) 10 | if(is.null(status)) stop("Must supply `status' argument") 11 | if( sum(status==0)+sum(status==1)!=length(y)) stop("status vector must have values 0 or 1") 12 | if (missing(beta) || is.null(beta)) stop("Must supply the solution beta") 13 | if (missing(lambda) || is.null(lambda)) stop("Must supply the tuning parameter value lambda") 14 | checkargs.misc(beta=beta,lambda=lambda,alpha=alpha, 15 | gridrange=gridrange,tol.beta=tol.beta,tol.kkt=tol.kkt) 16 | if (!is.null(bits) && !requireNamespace("Rmpfr",quietly=TRUE)) { 17 | warning("Package Rmpfr is not installed, reverting to standard precision") 18 | bits = NULL 19 | } 20 | 21 | n=nrow(x) 22 | p=ncol(x) 23 | nvar=sum(beta!=0) 24 | pv=vlo=vup=sd=rep(NA, nvar) 25 | ci=tailarea=matrix(NA,nvar,2) 26 | 27 | 28 | m=beta!=0 29 | vars=which(m) 30 | if(sum(m)>0){ 31 | bhat=beta[beta!=0] #penalized coefs just for active variables 32 | sign_bhat=sign(bhat) 33 | 34 | #check KKT 35 | 36 | aaa=coxph(Surv(y,status)~x[,m],init=bhat,iter.max=0) # this gives the Cox model at exactly bhat 37 | # so when we compute gradient and score 38 | # we are evaluating at the LASSO solution 39 | # naming of variables could be improved... 40 | res=residuals(aaa,type="score") 41 | if(!is.matrix(res)) res=matrix(res,ncol=1) 42 | scor=colSums(res) 43 | g=(scor+lambda*sign_bhat)/(2*lambda) 44 | # cat(c(g,lambda,tol.kkt),fill=T) 45 | if (any(abs(g) > 1+tol.kkt) ) 46 | warning(paste("Solution beta does not satisfy the KKT conditions", 47 | "(to within specified tolerances)")) 48 | 49 | # Hessian of partial likelihood at the LASSO solution 50 | MM=vcov(aaa) 51 | 52 | bbar=(bhat+lambda*MM%*%sign_bhat) 53 | A1=-(mydiag(sign_bhat)) 54 | b1= -(mydiag(sign_bhat)%*%MM)%*%sign_bhat*lambda 55 | 56 | temp=max(A1%*%bbar-b1) 57 | 58 | 59 | # compute p-values 60 | 61 | # JT: are we sure the signs of these are correctly handled? 62 | # two sided p-values numerically agree with python but 63 | # the one sided p-values are a bit off 64 | 65 | for(jj in 1:length(bbar)){ 66 | vj=rep(0,length(bbar));vj[jj]=sign_bhat[jj] 67 | 68 | 69 | junk=TG.pvalue(bbar, A1, b1, vj,MM) 70 | 71 | pv[jj] = junk$pv 72 | vlo[jj]=junk$vlo 73 | vup[jj]=junk$vup 74 | sd[jj]=junk$sd 75 | 76 | junk2=TG.interval(bbar, A1, b1, vj, MM, alpha, flip=(sign_bhat[jj]==-1)) 77 | ci[jj,]=junk2$int 78 | tailarea[jj,] = junk2$tailarea 79 | 80 | } 81 | # JT: these don't seem to be the real one-step estimators 82 | fit0=coxph(Surv(y,status)~x[,m]) 83 | coef0=fit0$coef 84 | se0=sqrt(diag(fit0$var)) 85 | zscore0=coef0/se0 86 | 87 | out = list(lambda=lambda,pv=pv,ci=ci, 88 | tailarea=tailarea,vlo=vlo,vup=vup,sd=sd, 89 | vars=vars,alpha=alpha,coef0=coef0,zscore0=zscore0, 90 | call=this.call) 91 | class(out) = "fixedCoxLassoInf" 92 | } 93 | return(out) 94 | } 95 | 96 | 97 | 98 | print.fixedCoxLassoInf <- function(x, tailarea=TRUE, ...) { 99 | cat("\nCall:\n") 100 | dput(x$call) 101 | 102 | cat(sprintf("\nStandard deviation of noise (specified or estimated) sigma = %0.3f\n", 103 | x$sigma)) 104 | 105 | cat(sprintf("\nTesting results at lambda = %0.3f, with alpha = %0.3f\n",x$lambda,x$alpha)) 106 | cat("",fill=T) 107 | tab = cbind(x$vars, 108 | round(x$coef0,3), 109 | round(x$zscore0,3), 110 | round(x$pv,3),round(x$ci,3)) 111 | colnames(tab) = c("Var", "Coef", "Z-score", "P-value", "LowConfPt", "UpConfPt") 112 | if (tailarea) { 113 | tab = cbind(tab,round(x$tailarea,3)) 114 | colnames(tab)[(ncol(tab)-1):ncol(tab)] = c("LowTailArea","UpTailArea") 115 | } 116 | rownames(tab) = rep("",nrow(tab)) 117 | print(tab) 118 | 119 | cat(sprintf("\nNote: coefficients shown are %s regression coefficients\n", 120 | ifelse(x$type=="partial","partial","full"))) 121 | invisible() 122 | } 123 | 124 | 125 | -------------------------------------------------------------------------------- /selectiveInference/R/funs.max.R: -------------------------------------------------------------------------------- 1 | #Mills lower bound on the integral of a standard normal over an interval 2 | #Need to use something else near zero, where mills is bad. 3 | mills.lb = function(a,b){ 4 | t=5#threshold for switching to approximation 5 | if(b=t){ 7 | return(a*exp(-a^2/2)/(1+a^2)-exp(-b^2/2)/b) 8 | } 9 | if(b <= -t){ 10 | return(mills.lb(-b,-a)) 11 | } 12 | #Note, like in the rest of this program, I'm not dividing by sqrt(2*pi), so we need to rescale here 13 | sqrt(2*pi)*pnorm(min(b,t))-sqrt(2*pi)*pnorm(max(a,-t))+mills.lb(a,-t)+mills.lb(t,b) 14 | } 15 | 16 | 17 | #Truncate the interval. We chop off the ends near infinity, being careful 18 | #so that the chopped tail is guaranteed to be close enough to its mills approximation 19 | #a,b are the left and right endpoints, z is the mid point 20 | #delta is the multiplicative error limit of the truncation on the final fraction (roughly) 21 | truncate.interval = function(a,b,z,delta=1e-16){ 22 | #Initialize some stuff 23 | L.extra = 0#Extra probability to be added for the truncation on the left 24 | R.extra = 0#Extra probability to be added for the truncation on the right 25 | a.new = a#truncated interval bounds 26 | b.new = b#truncated interval bounds 27 | 28 | #We need bounds on the integrals 29 | RL.lb = mills.lb(a,b) 30 | R.lb = mills.lb(z,b) 31 | 32 | #Now we bound the error we can tolerate in the tail approximations 33 | eps.R = min(delta*R.lb,delta*RL.lb/2) 34 | eps.L = delta*RL.lb/2 35 | 36 | #For now, only truncate infinite end points 37 | #Might want to change this one day, if we have trouble with super wide but finite intervals 38 | if (b==Inf){ 39 | f = function(x){x^2+log(1+x^2)+log(eps.R)}#encodes error of mills approximation 40 | b.new = uniroot(f,c(1.1,1000))$root 41 | b.new = max(b.new,z+1)#Don't truncate past z 42 | R.extra = exp(-b.new^2/2)/b.new 43 | } 44 | if (a==-Inf){ 45 | f = function(x){x^2+log(1+x^2)+log(eps.L)}#encodes error of mills approximation 46 | a.new = -uniroot(f,c(1.1,1000))$root 47 | a.new = min(a.new,z-1)#Don't truncate past z 48 | L.extra = exp(-a.new^2/2)/a.new 49 | } 50 | 51 | list(a=a.new,b=b.new,L.extra=L.extra,R.extra=R.extra,z=z) 52 | } 53 | 54 | 55 | #Approximates integral_a^b e^{-x^2/2+offset^2/2} dx 56 | # offset is used to make ratios slightly more stable 57 | # defaults to offset=0 58 | # Note that I've left out 1/sqrt(2*pi), you can add it in if you like 59 | approx.int = function(a,b,n=1000,offset=0){ 60 | delta = (b-a)/n #Step size, may want to vary in the future 61 | x = seq(from=a,to=b,by=delta) 62 | y = -x^2/2 + offset^2/2 # On the log scale 63 | m = diff(y)/diff(x) # Line segment slopes 64 | de = diff(exp(y)) # Difference on original scale 65 | sum(de/m) #Sum of integrals of line segments (closed form) 66 | } 67 | 68 | #Uses approx.int to evaluate int_x^b phi(z)dz / int_a^b phi(z)dz 69 | #Right now offsets everything for a little more stability 70 | #Uses truncation to handle infinite endpoints 71 | max.approx.frac = function(a,b,x,mu=0,n=1000){ 72 | returns = numeric(length(mu)) 73 | for(i in 1:length(returns)){ 74 | truncation = truncate.interval(a-mu[i],b-mu[i],x-mu[i]) 75 | #Our offset will use the smaller of a and b in absolute value 76 | offset = min(abs(truncation$a),abs(truncation$b)) 77 | #The truncation also shifts by the mean, so we don't need to do it again for the end points 78 | #but we do need to use the center z returned by truncation, rather than x, to match 79 | left = approx.int(truncation$a,truncation$z,n,offset)+truncation$L.extra 80 | right = approx.int(truncation$z,truncation$b,n,offset)+truncation$R.extra 81 | returns[i] = right/(left+right) 82 | } 83 | returns 84 | } 85 | -------------------------------------------------------------------------------- /selectiveInference/R/funs.randomizedMLE.R: -------------------------------------------------------------------------------- 1 | # This function computes the approximate UMVU as described 2 | # in Lemma 4 of https://arxiv.org/abs/1703.06176 3 | 4 | # - \Lambda^*_g is the quadratic form with randomizer_precision 5 | # - P is opt_transform$linear_term 6 | # - D is target_transform$linear_term 7 | # - q is target_transform$offset_term + opt_transform$offset_term 8 | 9 | solve_UMVU = function(target_transform, 10 | opt_transform, 11 | target_observed, 12 | feasible_point, 13 | target_cov, 14 | randomizer_precision, 15 | nstep=30, 16 | tol=1.e-8) { 17 | 18 | D = target_transform$linear_term; data_offset = target_transform$offset_term 19 | P = opt_transform$linear_term; opt_offset = opt_transform$offset_term 20 | q = data_offset + opt_offset 21 | 22 | print(c('D',D)) 23 | print(c('P',P)) 24 | print(c('q',q)) 25 | 26 | nopt = ncol(P) 27 | ntarget = ncol(D) 28 | ntotal = nopt + ntarget 29 | 30 | # setup joint implied covariance matrix 31 | 32 | target_precision = solve(target_cov) 33 | implied_precision = matrix(0, ntarget + nopt, ntarget + nopt) 34 | 35 | implied_precision[1:ntarget,1:ntarget] = t(D) %*% randomizer_precision %*% D + target_precision 36 | implied_precision[1:ntarget,(ntarget+1):ntotal] = t(D) %*% randomizer_precision %*% P 37 | implied_precision[(ntarget+1):ntotal,1:ntarget] = t(P) %*% randomizer_precision %*% D 38 | implied_precision[(ntarget+1):ntotal,(ntarget+1):ntotal] = t(P) %*% randomizer_precision %*% P 39 | implied_cov = solve(implied_precision) 40 | 41 | implied_opt = implied_cov[(ntarget+1):ntotal,(ntarget+1):ntotal,drop=FALSE] 42 | implied_target = implied_cov[1:ntarget,1:ntarget,drop=FALSE] 43 | implied_cross = implied_cov[1:ntarget,(ntarget+1):ntotal,drop=FALSE] 44 | 45 | L = implied_cross %*% solve(implied_opt) 46 | M_1 = solve(implied_precision[1:ntarget,1:ntarget,drop=FALSE]) %*% target_precision 47 | M_2 = -solve(implied_precision[1:ntarget,1:ntarget,drop=FALSE]) %*% t(D) %*% randomizer_precision 48 | 49 | conditioned_value = q 50 | 51 | linear_term = t(implied_cross) %*% solve(implied_target) 52 | offset_term = -t(P) %*% randomizer_precision %*% conditioned_value 53 | natparam_transform = list(linear_term=linear_term, offset_term=offset_term) 54 | conditional_natural_parameter = linear_term %*% target_observed + offset_term 55 | 56 | conditional_precision = implied_precision[(ntarget+1):ntotal,(ntarget+1):ntotal,drop=FALSE] 57 | 58 | M_1_inv = solve(M_1) 59 | offset_term = - M_1_inv %*% M_2 %*% conditioned_value 60 | mle_transform = list(target_lin=M_1_inv, soln_lin=-M_1_inv %*% L, offset=offset_term) 61 | 62 | mle_map = function(target_observed, feasible_point=rep(1, length(target_observed))) { 63 | param_lin = natparam_transform$linear_term 64 | param_offset = natparam_transform$offset_term 65 | mle_target_lin = mle_transform$target_lin 66 | mle_soln_lin = mle_transform$soln_lin 67 | mle_offset = mle_transform$offset 68 | 69 | conjugate_arg = as.vector(param_lin %*% target_observed + param_offset) 70 | scaling = mean(diag(conditional_precision)) * 1. 71 | print('conjugate') 72 | print(conjugate_arg) 73 | print('precision') 74 | print(conditional_precision) 75 | print('feasible') 76 | print(feasible_point) 77 | 78 | result = solve_barrier_(conjugate_arg * 1., 79 | conditional_precision * 1., 80 | feasible_point * 1., 81 | nstep, 82 | tol, 83 | scaling) 84 | 85 | print('value') 86 | value = sum(-conjugate_arg * result$soln) + 0.5 * sum(result$soln * (conditional_precision %*% result$soln)) + log((result$soln + scaling) / result$soln) 87 | print(value) 88 | 89 | return(list(soln=as.vector(mle_target_lin %*% target_observed + mle_soln_lin %*% result$soln + mle_offset), 90 | cond_exp=result$soln, 91 | value=result$value, 92 | gradient=result$gradient)) 93 | } 94 | sel_MLE = mle_map(target_observed) 95 | print("MLE") 96 | print(sel_MLE) 97 | return(list(soln=sel_MLE$soln, value=sel_MLE$value, map=mle_map, gradient=sel_MLE$gradient)) 98 | } 99 | -------------------------------------------------------------------------------- /selectiveInference/R/funs.sampler.R: -------------------------------------------------------------------------------- 1 | # A no-rejection MCMC algorithm Jelena and Amir have been working on 2 | 3 | log_concave_sampler = function(negative_log_density, 4 | grad_negative_log_density, 5 | constraints, 6 | observed, 7 | nsamples, 8 | burnin){ 9 | #print(constraints) 10 | constraints = as.matrix(constraints) 11 | dim = nrow(constraints) 12 | 13 | get_poisson_process = function(state){ 14 | pos = as.matrix(state$pos) 15 | velocity = as.matrix(state$velocity) 16 | neg_velocity = velocity<0 17 | pos_velocity = velocity>0 18 | tau_min = 0 19 | tau_max = 10 20 | if (sum(neg_velocity)>0){ 21 | R = (-constraints[neg_velocity,1]+pos[neg_velocity])/(-velocity[neg_velocity]) 22 | tau_max = min(tau_max, min(R)) 23 | L = (-constraints[neg_velocity,2]+pos[neg_velocity])/(-velocity[neg_velocity]) 24 | tau_min = max(tau_min, max(L)) 25 | } 26 | if (sum(pos_velocity)>0){ 27 | R = (constraints[pos_velocity,2]-pos[pos_velocity])/velocity[pos_velocity] 28 | tau_max = min(tau_max, min(R)) 29 | L = (constraints[pos_velocity,1]-pos[pos_velocity])/velocity[pos_velocity] 30 | tau_min = max(tau_min, max(L)) 31 | } 32 | 33 | f=function(t){as.numeric(t(velocity) %*% grad_negative_log_density(pos+velocity*t))} 34 | tau_star = tau_max 35 | if (f(tau_min)*f(tau_max)<0){ 36 | tau_star = uniroot(f, c(tau_min, tau_max))$root 37 | } else{ 38 | if (negative_log_density(pos+velocity*tau_min) burnin) { 74 | samples[i - burnin,]=state$pos 75 | } 76 | state = compute_next(state) 77 | } 78 | return (samples) 79 | } 80 | 81 | gaussian_sampler = function(noise_scale, 82 | observed, 83 | linear_term, 84 | offset_term, 85 | constraints, 86 | nsamples=10000, 87 | burnin=2000){ 88 | 89 | negative_log_density = function(x) { 90 | recon = linear_term %*% x+offset_term 91 | return(as.numeric(t(recon)%*%recon/(2*noise_scale^2))) 92 | } 93 | grad_negative_log_density=function(x){ 94 | recon = linear_term %*% x+offset_term 95 | return(t(linear_term) %*% recon/(noise_scale^2)) 96 | } 97 | 98 | return(log_concave_sampler(negative_log_density, 99 | grad_negative_log_density, 100 | constraints, 101 | observed, 102 | nsamples, 103 | burnin)) 104 | } 105 | -------------------------------------------------------------------------------- /selectiveInference/R/linear.tests.R: -------------------------------------------------------------------------------- 1 | # robs.test <- function() { 2 | # n <- 100 3 | # p <- 200 4 | # 5 | # set.seed(11332) 6 | # 7 | # y <- matrix(rnorm(n),ncol=1) # rand N(0,1) response 8 | # X <- matrix(rnorm(p*n),ncol = p) # p rand N(0,1) predictors 9 | # 10 | # X=scale(X,T,T)/sqrt(n-1) 11 | # lambda=1 12 | # sigma = estimateSigma(X,y)$sigmahat 13 | # 14 | # las <- glmnet(X,y,family="gaussian",alpha=1,standardize=F,intercept=T) 15 | # hbeta <- as.numeric(coef(las,x=X,y=y,s=lambda/n,exact=TRUE,intercept=T)) 16 | # 17 | # 18 | # return(fixedLassoInf(X,y,hbeta[-1],lambda,family="gaussian",type="partial",intercept=T,sigma=sigma)) 19 | # } 20 | # 21 | # 22 | # ## Tests partial inf for X and y randomly generated from N(0,1) 23 | # nullTest <- function(X,y,lambda,intercept,type=c("full","partial")) { 24 | # n=nrow(X) 25 | # X=scale(X,T,T)/sqrt(n-1) 26 | # 27 | # sigma = estimateSigma(X,y)$sigmahat 28 | # 29 | # las <- glmnet(X,y,family="gaussian",alpha=1,standardize=F,intercept=intercept) 30 | # hbeta <- as.numeric(coef(las,x=X,y=y,s=lambda/n,exact=TRUE,intercept=intercept)) 31 | # 32 | # if (type=="partial" || intercept==F) hbeta = hbeta[-1] 33 | # 34 | # return(fixedLassoInf(X,y,hbeta,lambda,family="gaussian",type=type,intercept=intercept,sigma=sigma)) 35 | # } 36 | # 37 | # ## Test partial inf for X and y where 10 variables are y with random additive N(0,0.5) noise 38 | # corrTest <- function(X,y,lambda,intercept,type=c("full","partial")) { 39 | # n=nrow(X) 40 | # corr.X = rep(y,10) + matrix(rnorm(n*10,0,0.5),ncol = 10) 41 | # X = cbind(corr.X,X) 42 | # X=scale(X,T,T)/sqrt(n-1) 43 | # 44 | # las <- glmnet(X,y,family="gaussian",alpha=1,standardize=F,intercept=intercept) 45 | # hbeta <- as.numeric(coef(las,x=X,y=y,s=lambda/n,exact=TRUE,intercept=intercept)) 46 | # 47 | # sigma = estimateSigma(X,y)$sigmahat 48 | # 49 | # if (type=="partial" || intercept==F) hbeta = hbeta[-1] 50 | # 51 | # return(fixedLassoInf(X,y,hbeta,lambda,family="gaussian",type=type,intercept=intercept,sigma=sigma)) 52 | # } 53 | # 54 | # ## QQ plot of p-values for all null data now that bug fix is implemented 55 | # partial.qq.test <- function() { 56 | # n <- 100 57 | # p <- 200 58 | # 59 | # lambda=1 60 | # 61 | # null.int.pvs <- c() 62 | # corr.int.pvs <- c() 63 | # null.pvs <- c() 64 | # corr.pvs <- c() 65 | # for(i in 1:25) { 66 | # y <- matrix(rnorm(n),ncol=1) # rand N(0,1) response 67 | # X <- matrix(rnorm(p*n),ncol=p) # p rand N(0,1) predictors 68 | # 69 | # null <- nullTest(X,y,lambda,F,type="partial") 70 | # corr <- corrTest(X,y,lambda,F,type="partial") 71 | # null.pvs <- c(null.pvs,null$pv,recursive=T) 72 | # corr.pvs <- c(corr.pvs,corr$pv,recursive=T) 73 | # null.int <- nullTest(X,y,lambda,T,type="partial") 74 | # corr.int <- corrTest(X,y,lambda,T,type="partial") 75 | # null.int.pvs <- c(null.int.pvs,null.int$pv,recursive=T) 76 | # corr.int.pvs <- c(corr.int.pvs,corr.int$pv,recursive=T) 77 | # } 78 | # 79 | # qqplot(x=runif(length(null.pvs)),y=null.pvs,xlab="Expected",ylab="Observed",main="Partial Coef. Null X w/o Intercept") 80 | # abline(0,1) 81 | # qqplot(x=runif(length(corr.pvs)),y=corr.pvs,xlab="Expected",ylab="Observed",main="Partial Coef. 10 Corr. X w/o Intercept") 82 | # abline(0,1) 83 | # qqplot(x=runif(length(null.int.pvs)),y=null.int.pvs,xlab="Expected",ylab="Observed",main="Partial Coef. Null X w/ Intercept") 84 | # abline(0,1) 85 | # qqplot(x=runif(length(corr.int.pvs)),y=corr.int.pvs,xlab="Expected",ylab="Observed",main="Partial Coef. 10 Corr. X w/ Intercept") 86 | # abline(0,1) 87 | # } 88 | # 89 | # ## QQ plot of p-values for all null data now that bug fix is implemented 90 | # pop.qq.test <- function() { 91 | # n <- 100 92 | # p <- 200 93 | # 94 | # lambda=1 95 | # 96 | # null.int.pvs <- c() 97 | # corr.int.pvs <- c() 98 | # null.pvs <- c() 99 | # corr.pvs <- c() 100 | # for(i in 1:25) { 101 | # y <- matrix(rnorm(n),ncol=1) # rand N(0,1) response 102 | # X <- matrix(rnorm(p*n),ncol=p) # p rand N(0,1) predictors 103 | # 104 | # null <- nullTest(X,y,lambda,F,type="full") 105 | # corr <- corrTest(X,y,lambda,F,type="full") 106 | # null.pvs <- c(null.pvs,null$pv,recursive=T) 107 | # corr.pvs <- c(corr.pvs,corr$pv,recursive=T) 108 | # null.int <- nullTest(X,y,lambda,T,type="full") 109 | # corr.int <- corrTest(X,y,lambda,T,type="full") 110 | # null.int.pvs <- c(null.int.pvs,null.int$pv,recursive=T) 111 | # corr.int.pvs <- c(corr.int.pvs,corr.int$pv,recursive=T) 112 | # } 113 | # 114 | # qqplot(x=runif(length(null.pvs)),y=null.pvs,xlab="Expected",ylab="Observed",main="Pop Coef. Null X w/o Intercept") 115 | # abline(0,1) 116 | # qqplot(x=runif(length(corr.pvs)),y=corr.pvs,xlab="Expected",ylab="Observed",main="Pop Coef. 10 Corr. X w/o Intercept") 117 | # abline(0,1) 118 | # qqplot(x=runif(length(null.int.pvs)),y=null.int.pvs,xlab="Expected",ylab="Observed",main="Pop Coef. Null X w/ Intercept") 119 | # abline(0,1) 120 | # qqplot(x=runif(length(corr.int.pvs)),y=corr.int.pvs,xlab="Expected",ylab="Observed",main="Pop Coef. 10 Corr. X w/ Intercept") 121 | # abline(0,1) 122 | # } 123 | # 124 | # 125 | # 126 | # 127 | # ## QQ plot of p-values for data with correlated x now that bug fix implemented 128 | # power.partial.pval.dist <- function(n,p,intercept=T,lambda=1) { 129 | # pvs <- c() 130 | # for(i in 1:10) { 131 | # a <- powerPartialTest(n,p,intercept,lambda) 132 | # ps <- a$pv 133 | # pvs <- c(pvs,ps,recursive=T) 134 | # } 135 | # qqplot(x=runif(length(pvs)),y=pvs,xlab="Expected",ylab="Observed",main="Partial Coef. 10 Corr. X") 136 | # abline(0,1) 137 | # } -------------------------------------------------------------------------------- /selectiveInference/man/ROSI.Rd: -------------------------------------------------------------------------------- 1 | \name{ROSI} 2 | \alias{ROSI} 3 | \title{ 4 | Relevant One-step Selective Inference for the LASSO 5 | } 6 | \description{ 7 | Compute p-values and confidence intervals for the lasso estimate, at a 8 | fixed value of the tuning parameter lambda using the "relevant" 9 | conditioning event of arxiv.org/1801.09037. 10 | } 11 | \usage{ 12 | ROSI(X, 13 | y, 14 | soln, 15 | lambda, 16 | penalty_factor=NULL, 17 | dispersion=1, 18 | family=c('gaussian', 'binomial'), 19 | solver=c('QP', 'glmnet'), 20 | construct_ci=TRUE, 21 | debiasing_method=c("JM", "BN"), 22 | verbose=FALSE, 23 | level=0.9, 24 | use_debiased=TRUE) 25 | } 26 | \arguments{ 27 | \item{X}{ 28 | Matrix of predictors (n by p); 29 | } 30 | \item{y}{ 31 | Vector of outcomes (length n) 32 | } 33 | \item{soln}{ 34 | Estimated lasso coefficients (e.g., from glmnet). This is of length p 35 | (so the intercept is not included as the first component). 36 | 37 | Be careful! This function uses the "standard" lasso objective 38 | \deqn{ 39 | 1/2 \|y - X \beta\|_2^2 + \lambda \|\beta\|_1. 40 | } 41 | In contrast, glmnet multiplies the first term by a factor of 1/n. 42 | So after running glmnet, to extract the beta corresponding to a value lambda, 43 | you need to use \code{beta = coef(obj, s=lambda/n)[-1]}, 44 | where obj is the object returned by glmnet (and [-1] removes the intercept, 45 | which glmnet always puts in the first component) 46 | } 47 | \item{lambda}{ 48 | Value of lambda used to compute beta. See the above warning 49 | } 50 | \item{penalty_factor}{ 51 | Penalty factor as used by glmnet. 52 | Actual penalty used in solving the problem is 53 | \deqn{ 54 | \lambda \cdot \sum_{i=1}^p f_i |\beta_i| 55 | } 56 | with f being the penalty_factor. Defaults to vector of 1s. 57 | } 58 | \item{dispersion}{ 59 | Estimate of dispersion in the GLM. Can be taken to be 60 | 1 for logisitic and should be an estimate of the error variance 61 | for the Gaussian. 62 | } 63 | \item{family}{ 64 | Family used for likelihood. 65 | } 66 | \item{solver}{ 67 | Solver used to solve restricted problems needed to find truncation set. 68 | Each active variable requires solving a new LASSO problem obtained 69 | by zeroing out one coordinate of original problem. The "QP" choice 70 | uses coordinate descent for a specific value of lambda, rather than glmnet which 71 | would solve for a new path each time. 72 | } 73 | \item{construct_ci}{ 74 | Report confidence intervals or just p-values? 75 | } 76 | \item{debiasing_method}{ 77 | Which method should be used for debiasing? Choices are "JM" (Javanmard, Montanari) 78 | or "BN" (method described in arxiv.org/1703.03282). 79 | } 80 | \item{verbose}{ 81 | Print out progress along the way? Default is FALSE. 82 | } 83 | \item{level}{ 84 | Confidence level for intervals. 85 | } 86 | \item{use_debiased}{ 87 | Use the debiased estimate of the parameter or not. When FALSE, this is the 88 | method desribed in arxiv.org/1801.09037. The default TRUE often 89 | produces noticably shorter intervals and more powerful tests when 90 | p is comparable to n. Ignored when n

p, this agrees with 92 | method in arxiv.org/1801.09037. 93 | } 94 | } 95 | 96 | \details{ 97 | ??? 98 | } 99 | \value{ 100 | \item{active_set}{Active set of LASSO.} 101 | \item{pvalues}{Two-sided P-values for active variables.} 102 | \item{intervals}{Confidence intervals} 103 | \item{estimate}{Relaxed (i.e. unshrunk) selected estimates.} 104 | \item{std_err}{Standard error of relaxed estimates (pre-selection).} 105 | \item{dispersion}{Dispersion parameter.} 106 | \item{lower_trunc}{Lower truncation point. The estimates should be outside the interval formed by the lower and upper truncation poitns.} 107 | \item{upper_trunc}{Lower truncation point. The estimates should be outside the interval formed by the lower and upper truncation poitns.} 108 | \item{lambda}{Value of tuning parameter lambda used.} 109 | \item{penalty_factor}{Penalty factor used for solving problem.} 110 | \item{level}{Confidence level.} 111 | \item{call}{The call to fixedLassoInf.} 112 | } 113 | 114 | \references{ 115 | 116 | 117 | Keli Liu, Jelena Markovic, Robert Tibshirani. More powerful post-selection 118 | inference, with application to the Lasso. arXiv:1801.09037 119 | 120 | Tom Boot, Didier Nibbering. Inference in high-dimensional linear regression models. 121 | arXiv:1703.03282 122 | 123 | } 124 | \author{Jelena Markovic, Jonathan Taylor} 125 | 126 | \examples{ 127 | 128 | \donttest{ 129 | library(selectiveInference) 130 | library(glmnet) 131 | set.seed(43) 132 | 133 | n = 100 134 | p = 200 135 | s = 2 136 | sigma = 1 137 | 138 | x = matrix(rnorm(n*p),n,p) 139 | x = scale(x,TRUE,TRUE) 140 | 141 | beta = c(rep(10, s), rep(0,p-s)) / sqrt(n) 142 | y = x \%*\% beta + sigma*rnorm(n) 143 | 144 | # first run glmnet 145 | gfit = glmnet(x,y,standardize=FALSE) 146 | 147 | # extract coef for a given lambda; note the 1/n factor! 148 | # (and we don't save the intercept term) 149 | lambda = 4 * sqrt(n) 150 | lambda_glmnet = 4 / sqrt(n) 151 | beta = selectiveInference:::solve_problem_glmnet(x, 152 | y, 153 | lambda_glmnet, 154 | penalty_factor=rep(1, p), 155 | family="gaussian") 156 | # compute fixed lambda p-values and selection intervals 157 | out = ROSI(x, 158 | y, 159 | beta, 160 | lambda, 161 | dispersion=sigma^2) 162 | out 163 | 164 | # an alternate approximate inverse from Boot and Nibbering 165 | 166 | out = ROSI(x, 167 | y, 168 | beta, 169 | lambda, 170 | dispersion=sigma^2, 171 | debiasing_method="BN") 172 | out 173 | } 174 | } 175 | 176 | -------------------------------------------------------------------------------- /selectiveInference/man/TG.interval.Rd: -------------------------------------------------------------------------------- 1 | \name{TG.interval} 2 | \alias{TG.interval} 3 | 4 | \title{ 5 | Truncated Gaussian confidence interval. 6 | } 7 | \description{ 8 | Compute truncated Gaussian interval of Lee et al. (2016) with 9 | arbitrary affine selection and covariance. 10 | Z should satisfy A %*% Z elementwise less then or equal b. 11 | } 12 | \usage{ 13 | TG.interval(Z, A, b, eta, Sigma=NULL, alpha=0.1, 14 | gridrange=c(-100,100), 15 | gridpts=100, 16 | griddepth=2, 17 | flip=FALSE, 18 | bits=NULL) 19 | } 20 | \arguments{ 21 | \item{Z}{ 22 | Observed data (assumed to follow N(mu, Sigma) with sum(eta*mu)=null_value) 23 | } 24 | \item{A}{ 25 | Matrix specifiying affine inequalities AZ <= b 26 | } 27 | \item{b}{ 28 | Offsets in the affine inequalities AZ <= b. 29 | } 30 | \item{eta}{ 31 | Determines the target sum(eta*mu) and estimate sum(eta*Z). 32 | } 33 | \item{Sigma}{ 34 | Covariance matrix of Z. Defaults to identity. 35 | } 36 | \item{alpha}{ 37 | Significance level for confidence intervals (target is miscoverage alpha/2 in each tail) 38 | } 39 | \item{gridrange}{ 40 | Grid range for constructing confidence intervals, on the standardized scale. 41 | } 42 | \item{gridpts}{ 43 | ??????? 44 | } 45 | \item{griddepth}{ 46 | ??????? 47 | } 48 | \item{flip}{ 49 | ??????? 50 | } 51 | \item{bits}{ 52 | Number of bits to be used for p-value and confidence interval calculations. Default is 53 | NULL, in which case standard floating point calculations are performed. When not NULL, 54 | multiple precision floating point calculations are performed with the specified number 55 | of bits, using the R package \code{Rmpfr} (if this package is not installed, then a 56 | warning is thrown, and standard floating point calculations are pursued). 57 | Note: standard double precision uses 53 bits 58 | so, e.g., a choice of 200 bits uses about 4 times double precision. The confidence 59 | interval computation is sometimes numerically challenging, and the extra precision can be 60 | helpful (though computationally more costly). In particular, extra precision might be tried 61 | if the values in the output columns of \code{tailarea} differ noticeably from alpha/2. 62 | } 63 | } 64 | 65 | \details{ 66 | This function computes selective confidence intervals based on the polyhedral 67 | lemma of Lee et al. (2016). 68 | } 69 | 70 | \value{ 71 | \item{int}{Selective confidence interval.} 72 | \item{tailarea}{Realized tail areas (lower and upper) for each confidence interval.} 73 | } 74 | 75 | \references{ 76 | Jason Lee, Dennis Sun, Yuekai Sun, and Jonathan Taylor (2016). 77 | Exact post-selection inference, with application to the lasso. Annals of Statistics, 44(3), 907-927. 78 | 79 | Jonathan Taylor and Robert Tibshirani (2017) Post-selection inference for math L1-penalized likelihood models. 80 | Canadian Journal of Statistics, xx, 1-21. (Volume still not posted) 81 | 82 | } 83 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 84 | 85 | \examples{ 86 | A = diag(5) 87 | b = rep(1, 5) 88 | Z = rep(0, 5) 89 | Sigma = diag(5) 90 | eta = as.numeric(c(1, 1, 0, 0, 0)) 91 | TG.interval(Z, A, b, eta, Sigma) 92 | } 93 | -------------------------------------------------------------------------------- /selectiveInference/man/TG.limits.Rd: -------------------------------------------------------------------------------- 1 | \name{TG.limits} 2 | \alias{TG.limits} 3 | 4 | \title{ 5 | Truncation limits and standard deviation. 6 | } 7 | \description{ 8 | Compute truncated limits and SD for use in computing 9 | p-values or confidence intervals of Lee et al. (2016). 10 | Z should satisfy A %*% Z elementwise less then or equal b. 11 | } 12 | \usage{ 13 | TG.limits(Z, A, b, eta, Sigma) 14 | } 15 | \arguments{ 16 | \item{Z}{ 17 | Observed data (assumed to follow N(mu, Sigma) with sum(eta*mu)=null_value) 18 | } 19 | \item{A}{ 20 | Matrix specifiying affine inequalities AZ <= b 21 | } 22 | \item{b}{ 23 | Offsets in the affine inequalities AZ <= b. 24 | } 25 | \item{eta}{ 26 | Determines the target sum(eta*mu) and estimate sum(eta*Z). 27 | } 28 | \item{Sigma}{ 29 | Covariance matrix of Z. Defaults to identity. 30 | } 31 | } 32 | \details{ 33 | This function computes the limits of truncation and the implied 34 | standard deviation in the polyhedral lemma of Lee et al. (2016). 35 | } 36 | 37 | \value{ 38 | \item{vlo}{Lower truncation limits for statistic} 39 | \item{vup}{Upper truncation limits for statistic} 40 | \item{sd}{Standard error of sum(eta*Z)} 41 | } 42 | 43 | \references{ 44 | Jason Lee, Dennis Sun, Yuekai Sun, and Jonathan Taylor (2016). 45 | Exact post-selection inference, with application to the lasso. Annals of Statistics, 44(3), 907-927. 46 | 47 | Jonathan Taylor and Robert Tibshirani (2017) Post-selection inference for math L1-penalized likelihood models. 48 | Canadian Journal of Statistics, xx, 1-21. (Volume still not posted) 49 | 50 | } 51 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 52 | 53 | \examples{ 54 | A = diag(5) 55 | b = rep(1, 5) 56 | Z = rep(0, 5) 57 | Sigma = diag(5) 58 | eta = as.numeric(c(1, 1, 0, 0, 0)) 59 | TG.limits(Z, A, b, eta, Sigma) 60 | } 61 | -------------------------------------------------------------------------------- /selectiveInference/man/TG.pvalue.Rd: -------------------------------------------------------------------------------- 1 | \name{TG.pvalue} 2 | \alias{TG.pvalue} 3 | 4 | \title{ 5 | Truncated Gaussian p-value. 6 | } 7 | \description{ 8 | Compute truncated Gaussian p-value of Lee et al. (2016) with 9 | arbitrary affine selection and covariance. 10 | Z should satisfy A %*% Z elementwise less then or equal b. 11 | } 12 | \usage{ 13 | TG.pvalue(Z, A, b, eta, Sigma, null_value=0, bits=NULL) 14 | } 15 | \arguments{ 16 | \item{Z}{ 17 | Observed data (assumed to follow N(mu, Sigma) with sum(eta*mu)=null_value) 18 | } 19 | \item{A}{ 20 | Matrix specifiying affine inequalities AZ <= b 21 | } 22 | \item{b}{ 23 | Offsets in the affine inequalities AZ <= b. 24 | } 25 | \item{eta}{ 26 | Determines the target sum(eta*mu) and estimate sum(eta*Z). 27 | } 28 | \item{Sigma}{ 29 | Covariance matrix of Z. Defaults to identity. 30 | } 31 | \item{null_value}{Hypothesized value of sum(eta*mu) under the null. 32 | } 33 | \item{bits}{ 34 | Number of bits to be used for p-value and confidence interval calculations. Default is 35 | NULL, in which case standard floating point calculations are performed. When not NULL, 36 | multiple precision floating point calculations are performed with the specified number 37 | of bits, using the R package \code{Rmpfr} (if this package is not installed, then a 38 | warning is thrown, and standard floating point calculations are pursued). 39 | Note: standard double precision uses 53 bits 40 | so, e.g., a choice of 200 bits uses about 4 times double precision. The confidence 41 | interval computation is sometimes numerically challenging, and the extra precision can be 42 | helpful (though computationally more costly). In particular, extra precision might be tried 43 | if the values in the output columns of \code{tailarea} differ noticeably from alpha/2. 44 | } 45 | } 46 | \details{ 47 | This function computes selective p-values based on the polyhedral 48 | lemma of Lee et al. (2016). 49 | } 50 | 51 | \value{ 52 | \item{pv}{One-sided P-values for active variables, uses the fact we have conditioned on the sign.} 53 | \item{vlo}{Lower truncation limits for statistic} 54 | \item{vup}{Upper truncation limits for statistic} 55 | \item{sd}{Standard error of sum(eta*Z)} 56 | } 57 | 58 | \references{ 59 | Jason Lee, Dennis Sun, Yuekai Sun, and Jonathan Taylor (2016). 60 | Exact post-selection inference, with application to the lasso. Annals of Statistics, 44(3), 907-927. 61 | 62 | Jonathan Taylor and Robert Tibshirani (2017) Post-selection inference for math L1-penalized likelihood models. 63 | Canadian Journal of Statistics, xx, 1-21. (Volume still not posted) 64 | 65 | } 66 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 67 | 68 | \examples{ 69 | 70 | A = diag(5) 71 | b = rep(1, 5) 72 | Z = rep(0, 5) 73 | Sigma = diag(5) 74 | eta = as.numeric(c(1, 1, 0, 0, 0)) 75 | TG.pvalue(Z, A, b, eta, Sigma) 76 | TG.pvalue(Z, A, b, eta, Sigma, null_value=1) 77 | 78 | } 79 | -------------------------------------------------------------------------------- /selectiveInference/man/debiasingMatrix.Rd: -------------------------------------------------------------------------------- 1 | \name{debiasingMatrix} 2 | \alias{debiasingMatrix} 3 | \title{ 4 | Find an approximate inverse of a non-negative definite matrix. 5 | } 6 | \description{ 7 | Find some rows of an approximate inverse of a non-negative definite 8 | symmetric matrix by solving optimization problem described 9 | in Javanmard and Montanari (2013). Can be used for approximate 10 | Newton step from some consistent estimator (such as the LASSO) 11 | to find a debiased solution. 12 | } 13 | \usage{ 14 | debiasingMatrix(Xinfo, 15 | is_wide, 16 | nsample, 17 | rows, 18 | verbose=FALSE, 19 | bound=NULL, 20 | linesearch=TRUE, 21 | scaling_factor=1.5, 22 | max_active=NULL, 23 | max_try=10, 24 | warn_kkt=FALSE, 25 | max_iter=50, 26 | kkt_stop=TRUE, 27 | parameter_stop=TRUE, 28 | objective_stop=TRUE, 29 | kkt_tol=1.e-4, 30 | parameter_tol=1.e-4, 31 | objective_tol=1.e-4) 32 | } 33 | \arguments{ 34 | \item{Xinfo}{ 35 | Either a non-negative definite matrix S=t(X) %*% X / n or X itself. If 36 | is_wide is TRUE, then Xinfo should be X, otherwise it should be S. 37 | } 38 | \item{is_wide}{ 39 | Are we solving for rows of the debiasing matrix assuming it is 40 | a wide matrix so that Xinfo=X and the non-negative definite 41 | matrix of interest is t(X) %*% X / nrow(X). 42 | } 43 | \item{nsample}{ 44 | Number of samples used in forming the cross-covariance matrix. 45 | Used for default value of the bound parameter. 46 | } 47 | \item{rows}{ 48 | Which rows of the approximate inverse to compute. 49 | } 50 | \item{verbose}{ 51 | Print out progress as rows are being computed. 52 | } 53 | \item{bound}{ 54 | Initial bound parameter for each row. Will be changed 55 | if linesearch is TRUE. 56 | } 57 | \item{linesearch}{ 58 | Run a line search to find as small as possible a bound parameter for each row? 59 | } 60 | \item{scaling_factor}{ 61 | In the linesearch, the bound parameter is either multiplied or divided by this 62 | factor at each step. 63 | } 64 | \item{max_active}{ 65 | How large an active set to consider in solving the problem with coordinate descent. 66 | Defaults to max(50, 0.3*nsample). 67 | } 68 | \item{max_try}{ 69 | How many tries in the linesearch. 70 | } 71 | \item{warn_kkt}{ 72 | Warn if the problem does not seem to be feasible after running the coordinate 73 | descent algorithm. 74 | } 75 | \item{max_iter}{ 76 | How many full iterations to run of the coordinate descent for each 77 | value of the bound parameter. 78 | } 79 | \item{kkt_stop}{ 80 | If TRUE, check to stop coordinate descent when KKT conditions are approximately satisfied. 81 | } 82 | \item{parameter_stop}{ 83 | If TRUE, check to stop coordinate descent based on relative convergence of parameter vector, 84 | checked at geometrically spaced iterations 2^k. 85 | } 86 | \item{objective_stop}{ 87 | If TRUE, check to stop coordinate descent based on relative decrease of objective value, 88 | checked at geometrically spaced iterations 2^k. 89 | } 90 | \item{kkt_tol}{ 91 | Tolerance value for assessing whether KKT conditions for solving the 92 | dual problem and feasibility of the original problem. 93 | } 94 | \item{parameter_tol}{ 95 | Tolerance value for assessing convergence of the problem using relative 96 | convergence of the parameter. 97 | } 98 | \item{objective_tol}{ 99 | Tolerance value for assessing convergence of the problem using relative 100 | decrease of the objective. 101 | } 102 | } 103 | \details{ 104 | This function computes an approximate inverse 105 | as described in Javanmard and Montanari (2013), specifically 106 | display (4). The problem is solved by considering a dual 107 | problem which has an objective similar to a LASSO problem and is solvable 108 | by coordinate descent. For some values of bound the original 109 | problem may not be feasible, in which case the dual problem has no solution. 110 | An attempt to detect this is made by stopping when the active set grows quite 111 | large, determined by max_active. 112 | } 113 | 114 | \value{ 115 | \item{M}{Rows of approximate inverse of Sigma.} 116 | } 117 | 118 | \references{ 119 | Adel Javanmard and Andrea Montanari (2013). 120 | Confidence Intervals and Hypothesis Testing for High-Dimensional Regression. Arxiv: 1306.3171 121 | } 122 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 123 | 124 | \examples{ 125 | 126 | set.seed(10) 127 | n = 50 128 | p = 100 129 | X = matrix(rnorm(n * p), n, p) 130 | S = t(X) \%*\% X / n 131 | M = debiasingMatrix(S, FALSE, n, c(1,3,5)) 132 | M2 = debiasingMatrix(X, TRUE, n, c(1,3,5)) 133 | max(M - M2) 134 | } 135 | -------------------------------------------------------------------------------- /selectiveInference/man/estimateSigma.Rd: -------------------------------------------------------------------------------- 1 | \name{estimateSigma} 2 | \alias{estimateSigma} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Estimate the noise standard deviation in regression 6 | } 7 | \description{ 8 | Estimates the standard deviation of the noise, for use in the selectiveInference 9 | package 10 | } 11 | \usage{ 12 | estimateSigma(x, y, intercept=TRUE, standardize=TRUE) 13 | } 14 | \arguments{ 15 | \item{x}{ 16 | Matrix of predictors (n by p) 17 | } 18 | \item{y}{ 19 | Vector of outcomes (length n) 20 | } 21 | \item{intercept}{Should glmnet be run with an intercept? Default is TRUE} 22 | \item{standardize}{Should glmnet be run with standardized predictors? Default is TRUE} 23 | } 24 | \details{ 25 | This function estimates the standard deviation of the noise, in a linear regresion setting. 26 | A lasso regression is fit, using cross-validation to estimate the tuning parameter lambda. 27 | With sample size n, yhat equal to the predicted values and df being the number of nonzero 28 | coefficients from the lasso fit, the estimate of sigma is \code{sqrt(sum((y-yhat)^2) / (n-df-1))}. 29 | Important: if you are using glmnet to compute the lasso estimate, be sure to use the settings 30 | for the "intercept" and "standardize" arguments in glmnet and estimateSigma. Same applies to fs 31 | or lar, where the argument for standardization is called "normalize". 32 | } 33 | \value{ 34 | \item{sigmahat}{The estimate of sigma} 35 | \item{df}{The degrees of freedom of lasso fit used} 36 | } 37 | \references{ 38 | Stephen Reid, Jerome Friedman, and Rob Tibshirani (2014). 39 | A study of error variance estimation in lasso regression. arXiv:1311.5274. 40 | } 41 | 42 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 43 | 44 | \examples{ 45 | set.seed(33) 46 | n = 50 47 | p = 10 48 | sigma = 1 49 | x = matrix(rnorm(n*p),n,p) 50 | beta = c(3,2,rep(0,p-2)) 51 | y = x\%*\%beta + sigma*rnorm(n) 52 | 53 | # run forward stepwise 54 | fsfit = fs(x,y) 55 | 56 | # estimate sigma 57 | sigmahat = estimateSigma(x,y)$sigmahat 58 | 59 | # run sequential inference with estimated sigma 60 | out = fsInf(fsfit,sigma=sigmahat) 61 | out 62 | } 63 | 64 | 65 | -------------------------------------------------------------------------------- /selectiveInference/man/factorDesign.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/funs.groupfs.R 3 | \name{factorDesign} 4 | \alias{factorDesign} 5 | \title{Expand a data frame with factors to form a design matrix with the full binary encoding of each factor.} 6 | \usage{ 7 | factorDesign(df) 8 | } 9 | \arguments{ 10 | \item{df}{Data frame containing some columns which are \code{factors}.} 11 | } 12 | \value{ 13 | List containing 14 | \describe{ 15 | \item{x}{Design matrix, the first columns contain any numeric variables from the original date frame.} 16 | \item{index}{Group membership indicator for expanded matrix.} 17 | } 18 | } 19 | \description{ 20 | When using \code{\link{groupfs}} with factor variables call this function first to create a design matrix. 21 | } 22 | \examples{ 23 | \dontrun{ 24 | fd = factorDesign(warpbreaks) 25 | y = rnorm(nrow(fd$x)) 26 | fit = groupfs(fd$x, y, fd$index, maxsteps=2, intercept=F) 27 | pvals = groupfsInf(fit) 28 | } 29 | } 30 | 31 | -------------------------------------------------------------------------------- /selectiveInference/man/forwardStop.Rd: -------------------------------------------------------------------------------- 1 | \name{forwardStop} 2 | \alias{forwardStop} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | ForwardStop rule for sequential p-values 6 | } 7 | \description{ 8 | Computes the ForwardStop sequential stopping rule of G'Sell et al (2014) 9 | } 10 | \usage{ 11 | forwardStop(pv, alpha=0.1) 12 | } 13 | %- maybe also 'usage' for other objects documented here. 14 | \arguments{ 15 | \item{pv}{ 16 | Vector of **sequential** p-values, for example from fsInf or larInf 17 | } 18 | \item{alpha}{ 19 | Desired type FDR level (between 0 and 1) 20 | } 21 | } 22 | \details{ 23 | Computes the ForwardStop sequential stopping rule of G'Sell et al (2014). 24 | Guarantees FDR control at the level alpha, for independent p-values. 25 | } 26 | \value{ 27 | Step number for sequential stop. 28 | } 29 | \references{ 30 | Max Grazier G'Sell, Stefan Wager, Alexandra Chouldechova, and Rob Tibshirani (2014). 31 | Sequential selection procedures and Fflse Discovery Rate Control. arXiv:1309.5352. 32 | To appear in Journal of the Royal Statistical Society: Series B. 33 | } 34 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 35 | 36 | \examples{ 37 | set.seed(33) 38 | n = 50 39 | p = 10 40 | sigma = 1 41 | x = matrix(rnorm(n*p),n,p) 42 | beta = c(3,2,rep(0,p-2)) 43 | y = x\%*\%beta + sigma*rnorm(n) 44 | 45 | # run forward stepwise 46 | fsfit = fs(x,y) 47 | 48 | # compute sequential p-values and confidence intervals 49 | # (sigma estimated from full model) 50 | out = fsInf(fsfit) 51 | out 52 | 53 | # estimate optimal stopping point 54 | forwardStop(out$pv, alpha=.10) 55 | } 56 | -------------------------------------------------------------------------------- /selectiveInference/man/fs.Rd: -------------------------------------------------------------------------------- 1 | \name{fs} 2 | \alias{fs} 3 | %- Also NEED an '\alias' for EACH other topic documented here. 4 | \title{ 5 | Forward stepwise regression 6 | } 7 | \description{ 8 | This function implements forward stepwise regression, for use in the 9 | selectiveInference package 10 | } 11 | \usage{ 12 | fs(x, y, maxsteps=2000, intercept=TRUE, normalize=TRUE, verbose=FALSE) 13 | } 14 | \arguments{ 15 | \item{x}{ 16 | Matrix of predictors (n by p) 17 | } 18 | \item{y}{ 19 | Vector of outcomes (length n) 20 | } 21 | \item{maxsteps}{ 22 | Maximum number of steps to take 23 | } 24 | \item{intercept}{Should an intercept be included on the model? Default is TRUE} 25 | \item{normalize}{Should the predictors be normalized? Default is TRUE. (Note: 26 | this argument has no real effect on model selection since forward stepwise is 27 | scale invariant already; however, it is included for completeness, and to match 28 | the interface for the \code{lar} function) 29 | } 30 | \item{verbose}{Print out progress along the way? Default is FALSE} 31 | } 32 | 33 | \details{ 34 | This function implements forward stepwise regression, adding the predictor at each 35 | step that maximizes the absolute correlation between the predictors---once 36 | orthogonalized with respect to the current model---and the residual. This entry 37 | criterion is standard, and is equivalent to choosing the variable that achieves 38 | the biggest drop in RSS at each step; it is used, e.g., by the \code{step} function 39 | in R. Note that, for example, the \code{lars} package implements a stepwise option 40 | (with type="step"), but uses a (mildly) different entry criterion, based on maximal 41 | absolute correlation between the original (non-orthogonalized) predictors and the 42 | residual. 43 | } 44 | \value{ 45 | \item{action}{Vector of predictors in order of entry} 46 | \item{sign}{Signs of coefficients of predictors, upon entry} 47 | \item{df}{Degrees of freedom of each active model} 48 | \item{beta}{Matrix of regression coefficients for each model along the path, 49 | one column per model} 50 | \item{completepath}{Was the complete stepwise path computed?} 51 | \item{bls}{If completepath is TRUE, the full least squares coefficients} 52 | \item{Gamma}{Matrix that captures the polyhedral selection at each step} 53 | \item{nk}{Number of polyhedral constraints at each step in path} 54 | \item{vreg}{Matrix of linear contrasts that gives coefficients of variables 55 | to enter along the path} 56 | \item{x}{Matrix of predictors used} 57 | \item{y}{Vector of outcomes used} 58 | \item{bx}{Vector of column means of original x} 59 | \item{by}{Mean of original y} 60 | \item{sx}{Norm of each column of original x} 61 | \item{intercept}{Was an intercept included?} 62 | \item{normalize}{Were the predictors normalized?} 63 | \item{call}{The call to fs} 64 | } 65 | 66 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 67 | 68 | \seealso{ 69 | \code{\link{fsInf}}, \code{\link{predict.fs}},\code{\link{coef.fs}}, \code{\link{plot.fs}} 70 | } 71 | 72 | \examples{ 73 | set.seed(33) 74 | n = 50 75 | p = 10 76 | sigma = 1 77 | x = matrix(rnorm(n*p),n,p) 78 | beta = c(3,2,rep(0,p-2)) 79 | y = x\%*\%beta + sigma*rnorm(n) 80 | 81 | # run forward stepwise, plot results 82 | fsfit = fs(x,y) 83 | plot(fsfit) 84 | 85 | # compute sequential p-values and confidence intervals 86 | # (sigma estimated from full model) 87 | out = fsInf(fsfit) 88 | out 89 | } 90 | 91 | 92 | -------------------------------------------------------------------------------- /selectiveInference/man/groupfs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/funs.groupfs.R 3 | \name{groupfs} 4 | \alias{groupfs} 5 | \title{Select a model with forward stepwise.} 6 | \usage{ 7 | groupfs(x, y, index, maxsteps, sigma = NULL, k = 2, intercept = TRUE, 8 | center = TRUE, normalize = TRUE, aicstop = 0, verbose = FALSE) 9 | } 10 | \arguments{ 11 | \item{x}{Matrix of predictors (n by p).} 12 | 13 | \item{y}{Vector of outcomes (length n).} 14 | 15 | \item{index}{Group membership indicator of length p. Check that \code{sort(unique(index)) = 1:G} where \code{G} is the number of distinct groups.} 16 | 17 | \item{maxsteps}{Maximum number of steps for forward stepwise.} 18 | 19 | \item{sigma}{Estimate of error standard deviation for use in AIC criterion. This determines the relative scale between RSS and the degrees of freedom penalty. Default is NULL corresponding to unknown sigma. When NULL, \code{link{groupfsInf}} performs truncated F inference instead of truncated \eqn{\chi}. See \code{\link[stats]{extractAIC}} for details on the AIC criterion.} 20 | 21 | \item{k}{Multiplier of model size penalty, the default is \code{k = 2} for AIC. Use \code{k = log(n)} for BIC, or \code{k = 2log(p)} for RIC (best for high dimensions, when \eqn{p > n}). If \eqn{G < p} then RIC may be too restrictive and it would be better to use \code{log(G) < k < 2log(p)}.} 22 | 23 | \item{intercept}{Should an intercept be included in the model? Default is TRUE. Does not count as a step.} 24 | 25 | \item{center}{Should the columns of the design matrix be centered? Default is TRUE.} 26 | 27 | \item{normalize}{Should the design matrix be normalized? Default is TRUE.} 28 | 29 | \item{aicstop}{Early stopping if AIC increases. Default is 0 corresponding to no early stopping. Positive integer values specify the number of times the AIC is allowed to increase in a row, e.g. with \code{aicstop = 2} the algorithm will stop if the AIC criterion increases for 2 steps in a row. The default of \code{\link[stats]{step}} corresponds to \code{aicstop = 1}.} 30 | 31 | \item{verbose}{Print out progress along the way? Default is FALSE.} 32 | } 33 | \value{ 34 | An object of class "groupfs" containing information about the sequence of models in the forward stepwise algorithm. Call the function \code{\link{groupfsInf}} on this object to compute selective p-values. 35 | } 36 | \description{ 37 | This function implements forward selection of linear models almost identically to \code{\link[stats]{step}} with \code{direction = "forward"}. The reason this is a separate function from \code{\link{fs}} is that groups of variables (e.g. dummies encoding levels of a categorical variable) must be handled differently in the selective inference framework. 38 | } 39 | \examples{ 40 | x = matrix(rnorm(20*40), nrow=20) 41 | index = sort(rep(1:20, 2)) 42 | y = rnorm(20) + 2 * x[,1] - x[,4] 43 | fit = groupfs(x, y, index, maxsteps = 5) 44 | out = groupfsInf(fit) 45 | out 46 | } 47 | \seealso{ 48 | \code{\link{groupfsInf}}, \code{\link{factorDesign}}. 49 | } 50 | 51 | -------------------------------------------------------------------------------- /selectiveInference/man/groupfsInf.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/funs.groupfs.R 3 | \name{groupfsInf} 4 | \alias{groupfsInf} 5 | \title{Compute selective p-values for a model fitted by \code{groupfs}.} 6 | \usage{ 7 | groupfsInf(obj, sigma = NULL, verbose = TRUE) 8 | } 9 | \arguments{ 10 | \item{obj}{Object returned by \code{\link{groupfs}} function} 11 | 12 | \item{sigma}{Estimate of error standard deviation. Default is NULL and in this case groupfsInf uses the value of sigma specified to \code{\link{groupfs}}.} 13 | 14 | \item{verbose}{Print out progress along the way? Default is TRUE.} 15 | } 16 | \value{ 17 | An object of class "groupfsInf" containing selective p-values for the fitted model \code{obj}. For comparison with \code{\link{fsInf}}, note that the option \code{type = "active"} is not available. 18 | 19 | \describe{ 20 | \item{vars}{Labels of the active groups in the order they were included.} 21 | \item{pv}{Selective p-values computed from appropriate truncated distributions.} 22 | \item{sigma}{Estimate of error variance used in computing p-values.} 23 | \item{TC or TF}{Observed value of truncated \eqn{\chi} or \eqn{F}.} 24 | \item{df}{Rank of group of variables when it was added to the model.} 25 | \item{support}{List of intervals defining the truncation region of the corresponding statistic.} 26 | } 27 | } 28 | \description{ 29 | Computes p-values for each group of variables in a model fitted by \code{\link{groupfs}}. These p-values adjust for selection by truncating the usual \eqn{\chi^2} statistics to the regions implied by the model selection event. If the \code{sigma} to \code{\link{groupfs}} was NULL then groupfsInf uses truncated \eqn{F} statistics instead of truncated \eqn{\chi}. The \code{sigma} argument to groupfsInf allows users to override and use \eqn{\chi}, but this is not recommended unless \eqn{\sigma} can be estimated well (i.e. \eqn{n > p}). 30 | } 31 | 32 | -------------------------------------------------------------------------------- /selectiveInference/man/lar.Rd: -------------------------------------------------------------------------------- 1 | \name{lar} 2 | \alias{lar} 3 | \title{ 4 | Least angle regression 5 | } 6 | \description{ 7 | This function implements least angle regression, for use in the 8 | selectiveInference package 9 | } 10 | \usage{ 11 | lar(x, y, maxsteps=2000, minlam=0, intercept=TRUE, normalize=TRUE, 12 | verbose=FALSE) 13 | } 14 | 15 | \arguments{ 16 | \item{x}{ 17 | Matrix of predictors (n by p) 18 | } 19 | \item{y}{ 20 | Vector of outcomes (length n) 21 | } 22 | \item{maxsteps}{ 23 | Maximum number of steps to take 24 | } 25 | \item{minlam}{ 26 | Minimum value of lambda to consider 27 | } 28 | \item{intercept}{Should an intercept be included on the model? Default is TRUE} 29 | \item{normalize}{Should the predictors be normalized? Default is TRUE} 30 | \item{verbose}{Print out progress along the way? Default is FALSE} 31 | } 32 | 33 | \details{ 34 | The least angle regression algorithm is described in detail by Efron et al. (2002). 35 | This function should match (in terms of its output) that from the \code{lars} package, 36 | but returns additional information (namely, the polyhedral constraints) needed for the 37 | selective inference calculations. 38 | } 39 | 40 | \value{ 41 | \item{lambda}{Values of lambda (knots) visited along the path} 42 | \item{action}{Vector of predictors in order of entry} 43 | \item{sign}{Signs of coefficients of predictors, upon entry} 44 | \item{df}{Degrees of freedom of each active model} 45 | \item{beta}{Matrix of regression coefficients for each model along the path, 46 | one model per column} 47 | \item{completepath}{Was the complete stepwise path computed?} 48 | \item{bls}{If completepath is TRUE, the full least squares coefficients} 49 | \item{Gamma}{Matrix that captures the polyhedral selection at each step} 50 | \item{nk}{Number of polyhedral constraints at each step in path} 51 | \item{vreg}{Matrix of linear contrasts that gives coefficients of variables 52 | to enter along the path} 53 | \item{mp}{Value of M+ (for internal use with the spacing test)} 54 | \item{x}{Matrix of predictors used} 55 | \item{y}{Vector of outcomes used} 56 | \item{bx}{Vector of column means of original x} 57 | \item{by}{Mean of original y} 58 | \item{sx}{Norm of each column of original x} 59 | \item{intercept}{Was an intercept included?} 60 | \item{normalize}{Were the predictors normalized?} 61 | \item{call}{The call to lar} 62 | } 63 | 64 | \references{ 65 | Brad Efron, Trevor Hastie, Iain Johnstone, and Rob Tibshirani (2002). 66 | Least angle regression. Annals of Statistics (with discussion). 67 | 68 | See also the descriptions in Trevor Hastie, Rob Tibshirani, and 69 | Jerome Friedman (2002, 2009). Elements of Statistical Learning. 70 | } 71 | 72 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Max G'Sell, Joshua Loftus, Stephen Reid} 73 | 74 | \seealso{ 75 | \code{\link{larInf}}, \code{\link{predict.lar}}, \code{\link{coef.lar}}, \code{\link{plot.lar}} 76 | } 77 | 78 | \examples{ 79 | set.seed(43) 80 | n = 50 81 | p = 10 82 | sigma = 1 83 | x = matrix(rnorm(n*p),n,p) 84 | beta = c(3,2,rep(0,p-2)) 85 | y = x\%*\%beta + sigma*rnorm(n) 86 | 87 | # run LAR, plot results 88 | larfit = lar(x,y) 89 | plot(larfit) 90 | 91 | # compute sequential p-values and confidence intervals 92 | # (sigma estimated from full model) 93 | out = larInf(larfit) 94 | out 95 | } 96 | -------------------------------------------------------------------------------- /selectiveInference/man/manyMeans.Rd: -------------------------------------------------------------------------------- 1 | \name{manyMeans} 2 | \alias{manyMeans} 3 | \title{ 4 | Selective inference for many normal means 5 | } 6 | \description{ 7 | Computes p-values and confidence intervals for the largest k 8 | among many normal means 9 | } 10 | \usage{ 11 | manyMeans(y, alpha=0.1, bh.q=NULL, k=NULL, sigma=1, verbose=FALSE) 12 | } 13 | 14 | \arguments{ 15 | \item{y}{Vector of outcomes (length n)} 16 | \item{alpha}{ 17 | Significance level for confidence intervals (target is miscoverage alpha/2 in each tail) 18 | } 19 | \item{bh.q}{q parameter for BH(q) procedure} 20 | \item{k}{Number of means to consider} 21 | \item{sigma}{Estimate of error standard deviation} 22 | \item{verbose}{Print out progress along the way? Default is FALSE} 23 | } 24 | \details{ 25 | This function compute p-values and confidence intervals for the largest k 26 | among many normal means. One can specify a fixed number of means k to consider, 27 | or choose the number to consider via the BH rule. 28 | } 29 | 30 | \value{ 31 | \item{mu.hat}{ Vector of length n containing the estimated signal sizes. 32 | If a sample element is not selected, then its signal size estimate is 0} 33 | \item{selected.set}{Indices of the vector y of the sample elements that 34 | were selected by the procedure (either BH(q) or top-K). Labelled "Selind" in output table.} 35 | \item{pv}{P-values for selected signals} 36 | \item{ci}{Confidence intervals} 37 | \item{method}{Method used to choose number of means} 38 | \item{sigma}{Value of error standard deviation (sigma) used} 39 | \item{bh.q}{BH q-value used} 40 | \item{k}{Desired number of means} 41 | \item{threshold}{Computed cutoff} 42 | \item{call}{The call to manyMeans} 43 | } 44 | 45 | \references{ 46 | Stephen Reid, Jonathan Taylor, and Rob Tibshirani (2014). 47 | Post-selection point and interval estimation of signal sizes in Gaussian samples. 48 | arXiv:1405.3340. 49 | } 50 | 51 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 52 | 53 | \examples{ 54 | set.seed(12345) 55 | n = 100 56 | mu = c(rep(3,floor(n/5)), rep(0,n-floor(n/5))) 57 | y = mu + rnorm(n) 58 | out = manyMeans(y, bh.q=0.1) 59 | out 60 | } 61 | -------------------------------------------------------------------------------- /selectiveInference/man/plot.fs.Rd: -------------------------------------------------------------------------------- 1 | \name{plot.fs} 2 | \alias{plot.fs} 3 | 4 | \title{ 5 | Plot function for forward stepwise regression 6 | } 7 | \description{ 8 | Plot coefficient profiles along the forward stepwise path 9 | } 10 | 11 | \usage{ 12 | \method{plot}{fs} (x, breaks=TRUE, omit.zeros=TRUE, var.labels=TRUE, ...) 13 | } 14 | 15 | \arguments{ 16 | \item{x}{ 17 | Object returned by a call to \code{fs} function 18 | } 19 | \item{breaks}{Should vertical lines be drawn at each break point in the piecewise 20 | linear coefficient paths? Default is TRUE} 21 | \item{omit.zeros}{Should segments of the coefficients paths that are equal to 22 | zero be omitted (to avoid clutter in the figure)? Default is TRUE} 23 | \item{var.labels}{Should paths be labelled with corresponding variable numbers? 24 | Default is TRUE} 25 | \item{...}{Additional arguments for plotting} 26 | } 27 | 28 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 29 | 30 | \examples{ 31 | set.seed(33) 32 | n = 50 33 | p = 10 34 | sigma = 1 35 | x = matrix(rnorm(n*p),n,p) 36 | beta = c(3,2,rep(0,p-2)) 37 | y = x\%*\%beta + sigma*rnorm(n) 38 | 39 | # run forward stepwise, plot results 40 | fsfit = fs(x,y) 41 | plot(fsfit) 42 | } 43 | -------------------------------------------------------------------------------- /selectiveInference/man/plot.lar.Rd: -------------------------------------------------------------------------------- 1 | \name{plot.lar} 2 | \alias{plot.lar} 3 | 4 | \title{ 5 | Plot function for least angle regression 6 | } 7 | \description{ 8 | Plot coefficient profiles along the LAR path 9 | } 10 | 11 | \usage{ 12 | \method{plot}{lar}(x, xvar=c("norm","step","lambda"), breaks=TRUE, 13 | omit.zeros=TRUE, var.labels=TRUE, ...) 14 | } 15 | 16 | \arguments{ 17 | \item{x}{ 18 | Object returned by a call to \code{lar} function 19 | (not the \code{lars} function!) 20 | } 21 | \item{xvar}{Either "norm" or "step" or "lambda", determining what is plotted 22 | on the x-axis} 23 | \item{breaks}{Should vertical lines be drawn at each break point in the piecewise 24 | linear coefficient paths? Default is TRUE} 25 | \item{omit.zeros}{Should segments of the coefficients paths that are equal to 26 | zero be omitted (to avoid clutter in the figure)? Default is TRUE} 27 | \item{var.labels}{Should paths be labelled with corresponding variable numbers? 28 | Default is TRUE} 29 | \item{...}{Additional arguments for plotting} 30 | } 31 | 32 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 33 | 34 | \examples{ 35 | set.seed(43) 36 | n = 50 37 | p = 10 38 | sigma = 1 39 | x = matrix(rnorm(n*p),n,p) 40 | beta = c(3,2,rep(0,p-2)) 41 | y = x\%*\%beta + sigma*rnorm(n) 42 | 43 | # run LAR, plot results 44 | larfit = lar(x,y) 45 | plot(larfit) 46 | } 47 | -------------------------------------------------------------------------------- /selectiveInference/man/predict.fs.Rd: -------------------------------------------------------------------------------- 1 | \name{predict.fs} 2 | \alias{predict.fs} 3 | \alias{coef.fs} 4 | 5 | \title{ 6 | Prediction and coefficient functions for forward stepwise 7 | regression 8 | } 9 | \description{ 10 | Make predictions or extract coefficients from a forward stepwise object 11 | } 12 | \usage{ 13 | \method{predict}{fs}(object, newx, s, ...) 14 | \method{coef}{fs}(object, s, ...) 15 | } 16 | 17 | \arguments{ 18 | \item{object}{ 19 | Object returned by a call to \code{fs} function 20 | } 21 | \item{newx}{ 22 | Matrix of x values at which the predictions are desired. If NULL, 23 | the x values from forward stepwise fitting are used 24 | } 25 | \item{s}{ 26 | Step number(s) at which predictions or coefficients are desired 27 | } 28 | \item{\dots}{Additional arguments} 29 | } 30 | 31 | \value{ 32 | Either a vector/matrix of predictions, or a vector/matrix of coefficients. 33 | } 34 | 35 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 36 | 37 | \examples{ 38 | set.seed(33) 39 | n = 200 40 | p = 20 41 | sigma = 1 42 | x = matrix(rnorm(n*p),n,p) 43 | beta = c(rep(3,10),rep(0,p-10)) 44 | y = x\%*\%beta + sigma*rnorm(n) 45 | 46 | # run forward stepwise and predict functions 47 | obj = fs(x,y) 48 | fit = predict(obj,x,s=3) 49 | } 50 | -------------------------------------------------------------------------------- /selectiveInference/man/predict.groupfs.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/funs.groupfs.R 3 | \name{predict.groupfs} 4 | \alias{predict.groupfs} 5 | \title{Prediction and coefficient functions for \code{\link{groupfs}}.} 6 | \description{ 7 | Make predictions or extract coefficients from a groupfs forward stepwise object.} 8 | \usage{ 9 | \method{predict}{groupfs}(object, newx) 10 | } 11 | \arguments{ 12 | \item{object}{Object returned by a call to \code{\link{groupfs}}.} 13 | 14 | \item{newx}{Matrix of x values at which the predictions are desired. If NULL, the x values from groupfs fitting are used.} 15 | } 16 | \value{ 17 | A vector of predictions or a vector of coefficients. 18 | } 19 | 20 | -------------------------------------------------------------------------------- /selectiveInference/man/predict.lar.Rd: -------------------------------------------------------------------------------- 1 | \name{predict.lar} 2 | \alias{predict.lar} 3 | \alias{coef.lar} 4 | 5 | \title{ 6 | Prediction and coefficient functions for least angle regression 7 | } 8 | \description{ 9 | Make predictions or extract coefficients from a least angle regression object 10 | } 11 | \usage{ 12 | \method{predict}{lar}(object, newx, s, mode=c("step","lambda"), ...) 13 | \method{coef}{lar}(object, s, mode=c("step","lambda"), ...) 14 | } 15 | 16 | \arguments{ 17 | \item{object}{ 18 | Object returned by a call to \code{lar} function 19 | (not the \code{lars} function!) 20 | } 21 | \item{newx}{ 22 | Matrix of x values at which the predictions are desired. If NULL, 23 | the x values from least angle regression fitting are used 24 | } 25 | \item{s}{ 26 | Step number(s) or lambda value(s) at which predictions or coefficients 27 | are desired 28 | } 29 | \item{mode}{Either "step" or "lambda", determining the role of s (above)} 30 | 31 | \item{\dots}{Additional arguments} 32 | } 33 | 34 | \value{ 35 | Either a vector/matrix of predictions, or a vector/matrix of coefficients. 36 | } 37 | 38 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 39 | 40 | \examples{ 41 | set.seed(33) 42 | n = 200 43 | p = 20 44 | sigma = 1 45 | x = matrix(rnorm(n*p),n,p) 46 | beta = c(rep(3,10),rep(0,p-10)) 47 | y = x\%*\%beta + sigma*rnorm(n) 48 | 49 | # run lar and predict functions 50 | obj = lar(x,y) 51 | fit = predict(obj,x,s=3) 52 | } 53 | -------------------------------------------------------------------------------- /selectiveInference/man/randomizedLasso.Rd: -------------------------------------------------------------------------------- 1 | \name{randomizedLasso} 2 | \alias{randomizedLasso} 3 | 4 | \title{ 5 | Inference for the randomized lasso, with a fixed lambda 6 | } 7 | \description{ 8 | Solve a randomly perturbed LASSO problem. 9 | } 10 | \usage{ 11 | randomizedLasso(X, 12 | y, 13 | lam, 14 | family=c("gaussian", "binomial"), 15 | noise_scale=NULL, 16 | ridge_term=NULL, 17 | max_iter=100, 18 | kkt_tol=1.e-4, 19 | parameter_tol=1.e-8, 20 | objective_tol=1.e-8, 21 | objective_stop=FALSE, 22 | kkt_stop=TRUE, 23 | parameter_stop=TRUE) 24 | } 25 | \arguments{ 26 | \item{X}{ 27 | Matrix of predictors (n by p); 28 | } 29 | \item{y}{ 30 | Vector of outcomes (length n) 31 | } 32 | \item{lam}{ 33 | Value of lambda used to compute beta. See the above warning 34 | Be careful! This function uses the "standard" lasso objective 35 | \deqn{ 36 | 1/2 \|y - x \beta\|_2^2 + \lambda \|\beta\|_1. 37 | } 38 | In contrast, glmnet multiplies the first term by a factor of 1/n. 39 | So after running glmnet, to extract the beta corresponding to a value lambda, 40 | you need to use \code{beta = coef(obj, s=lambda/n)[-1]}, 41 | where obj is the object returned by glmnet (and [-1] removes the intercept, 42 | which glmnet always puts in the first component) 43 | } 44 | \item{family}{ 45 | Response type: "gaussian" (default), "binomial". 46 | } 47 | \item{noise_scale}{ 48 | Scale of Gaussian noise added to objective. Default is 49 | 0.5 * sd(y) times the sqrt of the mean of the trace of X^TX. 50 | } 51 | \item{ridge_term}{ 52 | A small "elastic net" or ridge penalty is added to ensure 53 | the randomized problem has a solution. 54 | 0.5 * sd(y) times the sqrt of the mean of the trace of X^TX divided by 55 | sqrt(n). 56 | } 57 | \item{max_iter}{ 58 | How many rounds of updates used of coordinate descent in solving randomized 59 | LASSO. 60 | } 61 | \item{kkt_tol}{ 62 | Tolerance for checking convergence based on KKT conditions. 63 | } 64 | \item{parameter_tol}{ 65 | Tolerance for checking convergence based on convergence 66 | of parameters. 67 | } 68 | \item{objective_tol}{ 69 | Tolerance for checking convergence based on convergence 70 | of objective value. 71 | } 72 | \item{kkt_stop}{ 73 | Should we use KKT check to determine when to stop? 74 | } 75 | \item{parameter_stop}{ 76 | Should we use convergence of parameters to determine when to stop? 77 | } 78 | \item{objective_stop}{ 79 | Should we use convergence of objective value to determine when to stop? 80 | } 81 | } 82 | 83 | \details{For \code{family="gaussian"} this function uses the "standard" lasso objective 84 | \deqn{ 85 | 1/2 \|y - x \beta\|_2^2 + \lambda \|\beta\|_1 86 | } 87 | and adds a term 88 | \deqn{ 89 | - \omega^T\beta + \frac{\epsilon}{2} \|\beta\|^2_2 90 | } 91 | where omega is drawn from IID normals with standard deviation 92 | \code{noise_scale} and epsilon given by \code{ridge_term}. 93 | See below for default values of \code{noise_scale} and \code{ridge_term}. 94 | 95 | For \code{family="binomial"}, the squared error loss is replaced by the 96 | negative of the logistic log-likelihood. 97 | } 98 | \value{ 99 | \item{X}{Design matrix.} 100 | \item{y}{Response vector.} 101 | \item{lam}{Vector of penalty parameters.} 102 | \item{family}{Family: "gaussian" or "binomial".} 103 | \item{active_set}{Set of non-zero coefficients in randomized solution that were penalized. Integers from 1:p.} 104 | \item{inactive_set}{Set of zero coefficients in randomized solution. Integers from 1:p.} 105 | \item{unpenalized_set}{Set of non-zero coefficients in randomized solution that were not penalized. Integers from 1:p.} 106 | \item{sign_soln}{The sign pattern of the randomized solution.} 107 | \item{full_law}{List describing sampling parameters for conditional law of all optimization variables given the data in the LASSO problem.} 108 | \item{conditional_law}{List describing sampling parameters for conditional law of only the scaling variables given the data and the observed subgradient in the LASSO problem.} 109 | \item{internal_transform}{Affine transformation describing relationship between internal representation of the data and the data compontent of score of the likelihood at the unregularized MLE based on the sign_vector (a.k.a. relaxed LASSO).} 110 | \item{observed_raw}{Data component of the score at the unregularized MLE.} 111 | \item{noise_scale}{SD of Gaussian noise used to draw the perturbed objective.} 112 | \item{soln}{The randomized solution. Inference is made conditional on its sign vector (so no more snooping of this value is formally permitted.) 113 | If \code{condition_subgrad == TRUE} when sampling, then we may snoop on the observed subgradient.} 114 | \item{perturb}{The random vector in the linear term added to the objective.} 115 | } 116 | 117 | \references{ 118 | Xiaoying Tian, and Jonathan Taylor (2015). 119 | Selective inference with a randomized response. arxiv.org:1507.06739 120 | 121 | Xiaoying Tian, Snigdha Panigrahi, Jelena Markovic, Nan Bi and Jonathan Taylor (2016). 122 | Selective inference after solving a convex problem. 123 | arxiv:1609.05609 124 | 125 | } 126 | \author{Jelena Markovic, Jonathan Taylor} 127 | 128 | \examples{ 129 | set.seed(43) 130 | n = 50 131 | p = 10 132 | sigma = 0.2 133 | lam = 0.5 134 | 135 | X = matrix(rnorm(n*p), n, p) 136 | X = scale(X, TRUE, TRUE) / sqrt(n-1) 137 | 138 | beta = c(3,2,rep(0,p-2)) 139 | y = X\%*\%beta + sigma*rnorm(n) 140 | 141 | result = randomizedLasso(X, y, lam) 142 | 143 | } 144 | 145 | -------------------------------------------------------------------------------- /selectiveInference/man/randomizedLassoInf.Rd: -------------------------------------------------------------------------------- 1 | \name{randomizedLassoInf} 2 | \alias{randomizedLassoInf} 3 | 4 | \title{ 5 | Inference for the randomized lasso, with a fixed lambda 6 | } 7 | \description{ 8 | Compute p-values and confidence intervals based on selecting 9 | an active set with the randomized lasso, at a 10 | fixed value of the tuning parameter lambda and using Gaussian 11 | randomization. 12 | } 13 | \usage{ 14 | randomizedLassoInf(rand_lasso_soln, 15 | targets=NULL, 16 | level=0.9, 17 | sampler=c("norejection", "adaptMCMC"), 18 | nsample=10000, 19 | burnin=2000, 20 | opt_samples=NULL) 21 | } 22 | \arguments{ 23 | \item{rand_lasso_soln}{ 24 | A randomized lasso solution as returned by \code{randomizedLasso}. 25 | } 26 | \item{targets}{ 27 | If not NULL, should be a list with entries \code{observed_target, cov_target, crosscov_target_internal}. 28 | The \code{observed_target} should be (pre-selection) asymptotically Gaussian around targeted 29 | parameters. The quantity \code{cov_target} should be an estimate of the (pre-selection) covariance 30 | of \code{observed_target}. Finally, \code{crosscov_target_internal} should be an estimate of 31 | the (pre-selection) covariance of \code{observed_target} and the internal representation of the 32 | data of the LASSO. For both \code{"gaussian"} and \code{"binomial"}, this is the vector 33 | \deqn{ 34 | \hat{\beta}_{E,MLE}, X_{-E}^T(y - \mu(X_E\hat{\beta}_{E,MLE})) 35 | } 36 | For example, this cross-covariance could be estimated by jointly bootstrapping the target 37 | of interest and the above vector. 38 | } 39 | \item{level}{ 40 | Level for confidence intervals. 41 | } 42 | \item{sampler}{ 43 | Which sampler to use -- default is a no-rejection sampler. Otherwise 44 | use MCMC from the adaptMCMC package. 45 | } 46 | \item{nsample}{ 47 | Number of samples of optimization variables to sample. 48 | } 49 | \item{burnin}{ 50 | How many samples of optimization variable to discard (should be less than nsample). 51 | } 52 | \item{opt_samples}{ 53 | Optional sample of optimization variables. If not NULL then no MCMC will be run. 54 | } 55 | } 56 | 57 | \details{ 58 | This function computes selective p-values and confidence intervals for a 59 | randomized version of the lasso, 60 | given a fixed value of the tuning parameter lambda. 61 | 62 | } 63 | \value{ 64 | \item{targets}{A list with entries \code{observed_target, cov_target, crosscov_target_internal}. See argument description above.} 65 | \item{pvalues}{P-values testing hypotheses that each specific target is 0.} 66 | \item{ci}{Confidence interval for parameters determined by \code{targets}.} 67 | } 68 | 69 | \references{ 70 | Jelena Markovic and Jonathan Taylor (2016). 71 | Bootstrap inference after using multiple queries for model selection. arxiv.org:1612.07811 72 | 73 | Xiaoying Tian and Jonathan Taylor (2015). 74 | Selective inference with a randomized response. arxiv.org:1507.06739 75 | 76 | Xiaoying Tian, Snigdha Panigrahi, Jelena Markovic, Nan Bi and Jonathan Taylor (2016). 77 | Selective inference after solving a convex problem. 78 | arxiv.org:1609.05609 79 | 80 | } 81 | \author{Jelena Markovic, Jonathan Taylor} 82 | 83 | \examples{ 84 | set.seed(43) 85 | n = 50 86 | p = 10 87 | sigma = 0.2 88 | lam = 0.5 89 | 90 | X = matrix(rnorm(n*p), n, p) 91 | X = scale(X, TRUE, TRUE) / sqrt(n-1) 92 | 93 | beta = c(3,2,rep(0,p-2)) 94 | y = X\%*\%beta + sigma*rnorm(n) 95 | 96 | result = randomizedLasso(X, y, lam) 97 | inf_result = randomizedLassoInf(result) 98 | } 99 | 100 | -------------------------------------------------------------------------------- /selectiveInference/man/scaleGroups.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/funs.groupfs.R 3 | \name{scaleGroups} 4 | \alias{scaleGroups} 5 | \title{Center and scale design matrix by groups} 6 | \usage{ 7 | scaleGroups(x, index, center = TRUE, normalize = TRUE) 8 | } 9 | \arguments{ 10 | \item{x}{Design matrix.} 11 | 12 | \item{index}{Group membership indicator of length p.} 13 | 14 | \item{center}{Center groups, default is TRUE.} 15 | 16 | \item{normalize}{Scale groups by Frobenius norm, default is TRUE.} 17 | } 18 | \value{ 19 | \describe{ 20 | \item{x}{Optionally centered/scaled design matrix.} 21 | \item{xm}{Means of groups in original design matrix.} 22 | \item{xs}{Frobenius norms of groups in original design matrix.} 23 | } 24 | } 25 | \description{ 26 | For internal use by \code{\link{groupfs}}. 27 | } 28 | 29 | -------------------------------------------------------------------------------- /selectiveInference/man/selectiveInference-internal.Rd: -------------------------------------------------------------------------------- 1 | \name{selectiveInference-internal} 2 | \title{Internal PMA functions} 3 | \alias{print.fixedLassoInf} 4 | \alias{print.fs} 5 | \alias{print.fsInf} 6 | \alias{print.larInf} 7 | \alias{print.lar} 8 | \alias{print.manyMeans} 9 | \alias{print.ROSI} 10 | 11 | \description{Internal selectiveInference functions} 12 | \usage{ 13 | \method{print}{fs}(x, ...) 14 | \method{print}{fsInf}(x, tailarea = TRUE, ...) 15 | \method{print}{lar}(x,...) 16 | \method{print}{larInf}(x, tailarea = TRUE, ...) 17 | \method{print}{fixedLassoInf}(x, tailarea = TRUE, ...) 18 | \method{print}{manyMeans}(x, ...) 19 | \method{print}{ROSI}(x, ...) 20 | } 21 | \author{Ryan Tibshirani, Rob Tibshirani, Jonathan Taylor, Joshua Loftus, Stephen Reid} 22 | \keyword{internal} 23 | 24 | -------------------------------------------------------------------------------- /selectiveInference/src/.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.so 3 | *.dll 4 | -------------------------------------------------------------------------------- /selectiveInference/src/Makevars: -------------------------------------------------------------------------------- 1 | PKG_CFLAGS= -I. -DCOLUMN_MAJOR_ORDER 2 | PKG_CPPFLAGS= -I. -DCOLUMN_MAJOR_ORDER 3 | PKG_LIBS=-L. 4 | 5 | $(SHLIB): Rcpp Rcpp-matrixcomps.o Rcpp-debias.o RcppExports.o quadratic_program.o quadratic_program_wide.o 6 | 7 | clean: 8 | rm -f *o 9 | 10 | Rcpp: 11 | $(R_HOME)/bin/Rscript -e "library(Rcpp); Rcpp::compileAttributes('..')" -------------------------------------------------------------------------------- /selectiveInference/src/Rcpp-debias.cpp: -------------------------------------------------------------------------------- 1 | #include // need to include the main Rcpp header file 2 | #include // where solve_QP, solve_QP_wide are defined 3 | 4 | // Below, the gradient should be equal to Sigma * theta + linear_func!! 5 | // No check is done on this. 6 | 7 | // [[Rcpp::export]] 8 | Rcpp::List solve_QP(Rcpp::NumericMatrix Sigma, 9 | double bound, 10 | int max_iter, 11 | Rcpp::NumericVector theta, 12 | Rcpp::NumericVector linear_func, 13 | Rcpp::NumericVector gradient, 14 | Rcpp::IntegerVector ever_active, 15 | Rcpp::IntegerVector nactive, 16 | double kkt_tol, 17 | double objective_tol, 18 | double parameter_tol, 19 | int max_active, 20 | int kkt_stop, 21 | int objective_stop, 22 | int param_stop 23 | ) { 24 | 25 | int nrow = Sigma.nrow(); // number of features 26 | 27 | // Active set 28 | 29 | int irow; 30 | 31 | // Extract the diagonal 32 | Rcpp::NumericVector Sigma_diag(nrow); 33 | double *sigma_diag_p = Sigma_diag.begin(); 34 | 35 | Rcpp::NumericVector theta_old(nrow); 36 | 37 | for (irow=0; irow= max_active); 71 | 72 | return(Rcpp::List::create(Rcpp::Named("soln") = theta, 73 | Rcpp::Named("gradient") = gradient, 74 | Rcpp::Named("linear_func") = linear_func, 75 | Rcpp::Named("iter") = iter, 76 | Rcpp::Named("kkt_check") = kkt_check, 77 | Rcpp::Named("ever_active") = ever_active, 78 | Rcpp::Named("nactive") = nactive, 79 | Rcpp::Named("max_active_check") = max_active_check)); 80 | 81 | } 82 | 83 | 84 | // [[Rcpp::export]] 85 | Rcpp::List solve_QP_wide(Rcpp::NumericMatrix X, 86 | Rcpp::NumericVector bound, 87 | double ridge_term, 88 | int max_iter, 89 | Rcpp::NumericVector theta, 90 | Rcpp::NumericVector linear_func, 91 | Rcpp::NumericVector gradient, 92 | Rcpp::NumericVector X_theta, 93 | Rcpp::IntegerVector ever_active, 94 | Rcpp::IntegerVector nactive, 95 | double kkt_tol, 96 | double objective_tol, 97 | double parameter_tol, 98 | int max_active, 99 | int kkt_stop, 100 | int objective_stop, 101 | int param_stop 102 | ) { 103 | 104 | int ncase = X.nrow(); // number of cases 105 | int nfeature = X.ncol(); // number of features 106 | 107 | // Active set 108 | 109 | int icase, ifeature; 110 | 111 | // A vector to keep track of gradient updates 112 | 113 | Rcpp::IntegerVector need_update(nfeature); 114 | 115 | Rcpp::NumericVector theta_old(nfeature); 116 | 117 | // Extract the diagonal -- divide by ncase 118 | 119 | Rcpp::NumericVector nndef_diag(nfeature); 120 | double *nndef_diag_p = nndef_diag.begin(); 121 | 122 | for (ifeature=0; ifeature= max_active); 170 | 171 | // Make sure gradient is updated -- essentially a matrix multiply 172 | 173 | update_gradient_wide((double *) gradient.begin(), 174 | (double *) X_theta.begin(), 175 | (double *) X.begin(), 176 | (double *) linear_func.begin(), 177 | (int *) need_update.begin(), 178 | ncase, 179 | nfeature); 180 | 181 | return(Rcpp::List::create(Rcpp::Named("soln") = theta, 182 | Rcpp::Named("gradient") = gradient, 183 | Rcpp::Named("X_theta") = X_theta, 184 | Rcpp::Named("linear_func") = linear_func, 185 | Rcpp::Named("iter") = iter, 186 | Rcpp::Named("kkt_check") = kkt_check, 187 | Rcpp::Named("ever_active") = ever_active, 188 | Rcpp::Named("nactive") = nactive, 189 | Rcpp::Named("max_active_check") = max_active_check)); 190 | 191 | } 192 | -------------------------------------------------------------------------------- /selectiveInference/src/Rcpp-matrixcomps.cpp: -------------------------------------------------------------------------------- 1 | #include // need to include the main Rcpp header file 2 | #include // where update1, downdate1 are defined 3 | 4 | // [[Rcpp::export]] 5 | Rcpp::List update1_(Rcpp::NumericMatrix Q2, 6 | Rcpp::NumericVector w, 7 | int m, 8 | int k) { 9 | 10 | update1(Q2.begin(), 11 | w.begin(), 12 | m, 13 | k); 14 | 15 | return(Rcpp::List::create(Rcpp::Named("Q2") = Q2, 16 | Rcpp::Named("w") = w)); 17 | } 18 | 19 | // [[Rcpp::export]] 20 | Rcpp::List downdate1_(Rcpp::NumericMatrix Q1, 21 | Rcpp::NumericMatrix R, 22 | int j0, 23 | int m, 24 | int n) { 25 | 26 | downdate1(Q1.begin(), 27 | R.begin(), 28 | j0, 29 | m, 30 | n); 31 | 32 | return(Rcpp::List::create(Rcpp::Named("Q1") = Q1, 33 | Rcpp::Named("R") = R)); 34 | } 35 | -------------------------------------------------------------------------------- /tests/debiased_lasso/comparison_scaled.R: -------------------------------------------------------------------------------- 1 | source('javanmard_montanari.R') 2 | 3 | ############################################## 4 | 5 | # Runs nsims simulations under the global null, computing p-values 6 | # using both the old code (slow one using Adel's code) and the new 7 | # code (faster using Jon's code), and produces qq-plots for both. 8 | # Runing 50 sims takes about 10-15 mins because old code is slow, so 9 | # feel free to lower nsims if you want 10 | 11 | 12 | library(selectiveInference) 13 | library(glmnet) 14 | 15 | # set.seed(424) 16 | 17 | n=100 18 | p=200 19 | 20 | sigma=.5 21 | 22 | lambda=c(0.25, 0.5, 1) 23 | 24 | for (j in c(3,2,1)) { 25 | 26 | thresh = 1e-10 27 | 28 | beta=rep(0,p) 29 | type="full" 30 | 31 | nsim = 20 32 | 33 | scaling = sqrt(n) 34 | pvs_old = c() 35 | pvs_new <- c() 36 | pvs_old_0 = c() # don't add the offset correction 37 | pvs_new_0 = c() # don't add the offset correction 38 | for (i in 1:nsim) { 39 | cat(i,fill=T) 40 | x = matrix(rnorm(n*p),n,p) 41 | x = scale(x,T,T) / scaling 42 | mu = x%*%beta 43 | y=mu+sigma*rnorm(n) 44 | 45 | # first run glmnet 46 | gfit=glmnet(x,y,intercept=F,standardize=F,thresh=thresh) 47 | 48 | bhat = coef(gfit, s=lambda[j]/(sqrt(n) * scaling), exact=TRUE,x=x,y=y)[-1] 49 | 50 | if(sum(bhat != 0) > 0) { 51 | 52 | # compute fixed lambda p-values and selection intervals 53 | 54 | aa = fixedLassoInf(x,y,bhat,lambda[j]*sqrt(n) / scaling,intercept=F,sigma=sigma,type=type) 55 | bb = oldFixedLassoInf(x,y,bhat,lambda[j]*sqrt(n) / scaling,intercept=F,sigma=sigma,type=type) 56 | pvs_new <- c(pvs_new, aa$pv, recursive=TRUE) 57 | pvs_old <- c(pvs_old, bb$pv,recursive=TRUE) 58 | 59 | cat() 60 | } 61 | } 62 | 63 | #check uniformity 64 | 65 | png(paste('comparison_scaled', j, '.png', sep='')) 66 | plot(ecdf(pvs_old), pch=23, col='green', xlim=c(0,1), ylim=c(0,1), main='ECDF of p-values') 67 | plot(ecdf(pvs_new), pch=24, col='purple', add=TRUE) 68 | abline(0,1) 69 | legend("bottomright", legend=c("Old", "New"), pch=c(23,24), pt.bg=c("green","purple")) 70 | dev.off() 71 | } -------------------------------------------------------------------------------- /tests/debiased_lasso/comparison_unscaled.R: -------------------------------------------------------------------------------- 1 | source('javanmard_montanari.R') 2 | 3 | ############################################## 4 | 5 | # Runs nsims simulations under the global null, computing p-values 6 | # using both the old code (slow one using Adel's code) and the new 7 | # code (faster using Jon's code), and produces qq-plots for both. 8 | # Runing 50 sims takes about 10-15 mins because old code is slow, so 9 | # feel free to lower nsims if you want 10 | 11 | 12 | library(selectiveInference) 13 | library(glmnet) 14 | 15 | # set.seed(424) 16 | 17 | n=100 18 | p=200 19 | 20 | sigma=.5 21 | 22 | lambda=c(0.25, 0.5, 1) 23 | 24 | for (j in c(3,2,1)) { 25 | 26 | thresh = 1e-10 27 | 28 | beta=rep(0,p) 29 | type="full" 30 | 31 | nsim = 20 32 | 33 | scaling = sqrt(n) 34 | pvs_old = c() 35 | pvs_new <- c() 36 | pvs_old_0 = c() # don't add the offset correction 37 | pvs_new_0 = c() # don't add the offset correction 38 | for (i in 1:nsim) { 39 | cat(i,fill=T) 40 | x = matrix(rnorm(n*p),n,p) 41 | x = scale(x,T,T) / scaling 42 | mu = x%*%beta 43 | y=mu+sigma*rnorm(n) 44 | 45 | # first run glmnet 46 | gfit=glmnet(x,y,intercept=F,standardize=F,thresh=thresh) 47 | 48 | bhat = coef(gfit, s=lambda[j]/(sqrt(n) * scaling), exact=TRUE,x=x,y=y)[-1] 49 | 50 | if(sum(bhat != 0) > 0) { 51 | 52 | # compute fixed lambda p-values and selection intervals 53 | 54 | aa = fixedLassoInf(x,y,bhat,lambda[j]*sqrt(n) / scaling,intercept=F,sigma=sigma,type=type) 55 | bb = oldFixedLassoInf(x,y,bhat,lambda[j]*sqrt(n) / scaling,intercept=F,sigma=sigma,type=type) 56 | pvs_new <- c(pvs_new, aa$pv, recursive=TRUE) 57 | pvs_old <- c(pvs_old, bb$pv,recursive=TRUE) 58 | 59 | cat() 60 | } 61 | } 62 | 63 | #check uniformity 64 | 65 | png(paste('comparison_unscaled', j, '.png', sep='')) 66 | plot(ecdf(pvs_old), pch=23, col='green', xlim=c(0,1), ylim=c(0,1), main='ECDF of p-values') 67 | plot(ecdf(pvs_new), pch=24, col='purple', add=TRUE) 68 | abline(0,1) 69 | legend("bottomright", legend=c("Old", "New"), pch=c(23,24), pt.bg=c("green","purple")) 70 | dev.off() 71 | } -------------------------------------------------------------------------------- /tests/debiased_lasso/test_debiased_coverage.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | library(glmnet) 3 | library(MASS) 4 | 5 | 6 | debiased_lasso_inference=function(X, y, soln, loss, sigma_est, lambda, debias_mat){ 7 | 8 | n=nrow(X) 9 | p=ncol(X) 10 | fit = X%*%soln 11 | if (loss=="ls"){ 12 | diagonal = rep(1,n) 13 | W_root=diag(as.vector(diagonal)) 14 | residuals = y-fit 15 | } 16 | if (loss=="logit"){ 17 | diagonal = exp(fit/2)/(1+exp(fit)) ## sqrt(pi*(1-pi)) 18 | W_root = diag(as.vector(diagonal)) 19 | residuals = y-(exp(fit)/(1+exp(fit))) 20 | } 21 | 22 | if (debias_mat == "JM"){ 23 | M = selectiveInference:::approximate_JM(W_root %*% X, 1:p) 24 | estimator = soln + M %*% diag(as.vector(1/diagonal)) %*% residuals 25 | } else if (debias_mat=="BN"){ 26 | M = selectiveInference:::approximate_BN(X, 1:p) 27 | estimator = M %*% y-((M %*% X-diag(p)) %*% soln) 28 | } 29 | covariance = sigma_est^2*M %*% t(M) 30 | 31 | 32 | naive_pvalues=NULL 33 | naive_intervals = NULL 34 | 35 | for (i in 1:p){ 36 | naive_int = selectiveInference:::naive_CI(estimator[i], covariance[i,i]) 37 | naive_intervals = cbind(naive_intervals, naive_int) 38 | naive_pval=selectiveInference:::pvalue_naive_linear(estimator[i], covariance[i,i]) 39 | naive_pvalues = c(naive_pvalues, naive_pval) 40 | } 41 | return(list(naive_pvalues=naive_pvalues, naive_intervals=naive_intervals)) 42 | } 43 | 44 | 45 | compute_coverage = function(ci, beta){ 46 | nactive=length(beta) 47 | coverage_vector = rep(0, nactive) 48 | for (i in 1:nactive){ 49 | if (beta[i]>=ci[1,i] && beta[i]<=ci[2,i]){ 50 | coverage_vector[i]=1 51 | } else if (beta[i]0){ 113 | lines(ecdf(naive_pvalues), col="red") 114 | abline(0,1) 115 | } 116 | 117 | if (construct_ci){ 118 | 119 | naive_coverages=c(naive_coverages, compute_coverage(PVS$naive_intervals[, active_set], beta[active_set])) 120 | naive_lengths=c(naive_lengths, as.vector(PVS$naive_intervals[2,active_set]-PVS$naive_intervals[1,active_set])) 121 | print(c("naive coverage:", length(which(naive_coverages==1))/length(naive_coverages))) 122 | print(c("param on the left of CI:", length(which(naive_coverages==-1))/length(naive_coverages))) 123 | print(c("param on the right of CI:", length(which(naive_coverages==0))/length(naive_coverages))) 124 | 125 | print(c("naive length mean:", mean(naive_lengths))) 126 | print(c("naive length median:", median(naive_lengths))) 127 | } 128 | 129 | mc = selectiveInference:::selective.plus.BH(beta, 1:p, PVS$naive_pvalues[active_set], q=0.2) 130 | FDR_sample=c(FDR_sample, mc$FDR) 131 | power_sample=c(power_sample, mc$power) 132 | 133 | if (length(FDR_sample)>0){ 134 | print(c("FDR:", mean(FDR_sample))) 135 | print(c("power:", mean(power_sample))) 136 | } 137 | } 138 | 139 | if (is.null(outfile)){ 140 | outfile="debiased_coverage.rds" 141 | } 142 | 143 | saveRDS(list(naive_intervals=naive_intervals, naive_coverages=naive_coverages, naive_lengths=naive_lengths, 144 | naive_pvalues=naive_pvalues, 145 | FDR_sample=FDR_sample, power_sample=power_sample, 146 | n=n, p=p, s=s, snr=snr, rho=rho), file=outfile) 147 | 148 | return(NULL) 149 | } 150 | 151 | test_debiased_coverage() 152 | 153 | -------------------------------------------------------------------------------- /tests/debiased_lasso/test_debiasing.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | 3 | 4 | ## Approximates inverse covariance matrix theta 5 | InverseLinfty <- function(sigma, n, resol=1.5, bound=NULL, maxiter=50, threshold=1e-10, verbose = TRUE) { 6 | isgiven <- 1; 7 | if (is.null(bound)){ 8 | isgiven <- 0; 9 | } 10 | 11 | p <- nrow(sigma); 12 | M <- matrix(0, p, p); 13 | xperc = 0; 14 | xp = round(p/10); 15 | for (i in 1:p) { 16 | if ((i %% xp)==0){ 17 | xperc = xperc+10; 18 | if (verbose) { 19 | print(paste(xperc,"% done",sep="")); } 20 | } 21 | if (isgiven==0){ 22 | bound <- (1/sqrt(n)) * qnorm(1-(0.1/(p^2))); 23 | } 24 | bound.stop <- 0; 25 | try.no <- 1; 26 | incr <- 0; 27 | while ((bound.stop != 1)&&(try.no<10)){ 28 | last.beta <- beta 29 | output <- InverseLinftyOneRow(sigma, i, bound, maxiter=maxiter, threshold=threshold) 30 | beta <- output$optsol 31 | iter <- output$iter 32 | if (isgiven==1){ 33 | bound.stop <- 1 34 | } 35 | else{ 36 | if (try.no==1){ 37 | if (iter == (maxiter+1)){ 38 | incr <- 1; 39 | bound <- bound*resol; 40 | } else { 41 | incr <- 0; 42 | bound <- bound/resol; 43 | } 44 | } 45 | if (try.no > 1){ 46 | if ((incr == 1)&&(iter == (maxiter+1))){ 47 | bound <- bound*resol; 48 | } 49 | if ((incr == 1)&&(iter < (maxiter+1))){ 50 | bound.stop <- 1; 51 | } 52 | if ((incr == 0)&&(iter < (maxiter+1))){ 53 | bound <- bound/resol; 54 | } 55 | if ((incr == 0)&&(iter == (maxiter+1))){ 56 | bound <- bound*resol; 57 | beta <- last.beta; 58 | bound.stop <- 1; 59 | } 60 | } 61 | } 62 | try.no <- try.no+1 63 | } 64 | M[i,] <- beta; 65 | } 66 | return(M) 67 | } 68 | 69 | InverseLinftyOneRow <- function ( sigma, i, bound, maxiter=50, threshold=1e-10) { 70 | p <- nrow(sigma); 71 | rho <- max(abs(sigma[i,-i])) / sigma[i,i]; 72 | bound0 <- rho/(1+rho); 73 | beta <- rep(0,p); 74 | 75 | #if (bound >= bound0){ 76 | # beta[i] <- (1-bound0)/sigma[i,i]; 77 | # returnlist <- list("optsol" = beta, "iter" = 0); 78 | # return(returnlist); 79 | #} 80 | 81 | diff.norm2 <- 1; 82 | last.norm2 <- 1; 83 | iter <- 1; 84 | iter.old <- 1; 85 | beta[i] <- (1-bound0)/sigma[i,i]; 86 | beta.old <- beta; 87 | sigma.tilde <- sigma; 88 | diag(sigma.tilde) <- 0; 89 | vs <- -sigma.tilde%*%beta; 90 | 91 | while ((iter <= maxiter) && (diff.norm2 >= threshold*last.norm2)){ 92 | 93 | for (j in 1:p){ 94 | oldval <- beta[j]; 95 | v <- vs[j]; 96 | if (j==i) 97 | v <- v+1; 98 | beta[j] <- SoftThreshold(v,bound)/sigma[j,j]; 99 | if (oldval != beta[j]){ 100 | vs <- vs + (oldval-beta[j])*sigma.tilde[,j]; 101 | } 102 | } 103 | 104 | iter <- iter + 1; 105 | if (iter==2*iter.old){ 106 | d <- beta - beta.old; 107 | diff.norm2 <- sqrt(sum(d*d)); 108 | last.norm2 <-sqrt(sum(beta*beta)); 109 | iter.old <- iter; 110 | beta.old <- beta; 111 | #if (iter>10) 112 | # vs <- -sigma.tilde%*%beta; 113 | } 114 | 115 | # print(c(iter, maxiter, diff.norm2, threshold * last.norm2, threshold, bound)) 116 | 117 | } 118 | 119 | returnlist <- list("optsol" = beta, "iter" = iter) 120 | return(returnlist) 121 | } 122 | 123 | SoftThreshold <- function( x, lambda ) { 124 | # 125 | # Standard soft thresholding 126 | # 127 | if (x>lambda){ 128 | return (x-lambda);} 129 | else { 130 | if (x< (-lambda)){ 131 | return (x+lambda);} 132 | else { 133 | return (0); } 134 | } 135 | } 136 | 137 | 138 | ### Test 139 | 140 | n = 100; p = 50 141 | 142 | X = matrix(rnorm(n * p), n, p) 143 | S = t(X) %*% X / n 144 | 145 | debiasing_bound = 7.791408e-02 146 | 147 | tol = 1.e-12 148 | 149 | rows = as.integer(c(1:2)) 150 | print('here') 151 | print(rows) 152 | A1 = debiasingMatrix(S, FALSE, n, rows, bound=debiasing_bound, max_iter=1000, kkt_tol=tol, objective_tol=tol, parameter_tol=tol, linesearch=FALSE) 153 | 154 | A2 = debiasingMatrix(S / n, FALSE, n, rows, bound=debiasing_bound, max_iter=1000, kkt_tol=tol, objective_tol=tol, parameter_tol=tol, linesearch=FALSE) 155 | B1 = debiasingMatrix(X, TRUE, n, rows, bound=debiasing_bound, max_iter=1000, kkt_tol=tol, objective_tol=tol, parameter_tol=tol, linesearch=FALSE) 156 | B2 = debiasingMatrix(X / sqrt(n), TRUE, n, rows, bound=debiasing_bound, max_iter=1000, kkt_tol=tol, objective_tol=tol, parameter_tol=tol, linesearch=FALSE) 157 | 158 | C1 = InverseLinfty(S, n, bound=debiasing_bound, maxiter=1000)[rows,] 159 | C2 = InverseLinfty(S / n, n, bound=debiasing_bound, maxiter=1000)[rows,] 160 | 161 | par(mfrow=c(2,3)) 162 | 163 | plot(A1[1,], C1[1,]) 164 | plot(A1[1,], B1[1,]) 165 | plot(B1[1,], C1[1,]) 166 | 167 | plot(A1[1,], A2[1,]) 168 | plot(B1[1,], B2[1,]) 169 | plot(C1[1,], C2[1,]) 170 | 171 | print(c('A', sum(A1[1,] == 0))) 172 | print(c('B', sum(B1[1,] == 0))) 173 | print(c('C', sum(C1[1,] == 0))) 174 | 175 | ## Are our points feasible 176 | 177 | feasibility = function(S, soln, j, debiasing_bound) { 178 | p = nrow(S) 179 | E = rep(0, p) 180 | E[j] = 1 181 | G = S %*% soln - E 182 | return(c(max(abs(G)), debiasing_bound)) 183 | } 184 | 185 | print(c('feasibility A', feasibility(S, A1[1,], 1, debiasing_bound))) 186 | print(c('feasibility B', feasibility(S, B1[1,], 1, debiasing_bound))) 187 | print(c('feasibility C', feasibility(S, C1[1,], 1, debiasing_bound))) 188 | 189 | active_KKT = function(S, soln, j, debiasing_bound) { 190 | p = nrow(S) 191 | E = rep(0, p) 192 | E[j] = 1 193 | G = S %*% soln - E 194 | print(which(soln != 0)) 195 | print(G[j]) 196 | return(c(G[soln != 0] * sign(soln)[soln != 0], debiasing_bound)) 197 | } 198 | 199 | print(c('active_KKT A', active_KKT(S, A1[1,], 1, debiasing_bound))) 200 | print(c('active_KKT B', active_KKT(S, B1[1,], 1, debiasing_bound))) 201 | print(c('active_KKT C', active_KKT(S, C1[1,], 1, debiasing_bound))) 202 | 203 | 204 | -------------------------------------------------------------------------------- /tests/debiased_lasso/test_debiasing_wide.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | 3 | 4 | ## Approximates inverse covariance matrix theta 5 | InverseLinfty <- function(sigma, n, resol=1.5, bound=NULL, maxiter=50, threshold=1e-10, verbose = TRUE) { 6 | isgiven <- 1; 7 | if (is.null(bound)){ 8 | isgiven <- 0; 9 | } 10 | 11 | p <- nrow(sigma); 12 | M <- matrix(0, p, p); 13 | xperc = 0; 14 | xp = round(p/10); 15 | for (i in 1:p) { 16 | if ((i %% xp)==0){ 17 | xperc = xperc+10; 18 | if (verbose) { 19 | print(paste(xperc,"% done",sep="")); } 20 | } 21 | if (isgiven==0){ 22 | bound <- (1/sqrt(n)) * qnorm(1-(0.1/(p^2))); 23 | } 24 | bound.stop <- 0; 25 | try.no <- 1; 26 | incr <- 0; 27 | while ((bound.stop != 1)&&(try.no<10)){ 28 | last.beta <- beta 29 | output <- InverseLinftyOneRow(sigma, i, bound, maxiter=maxiter, threshold=threshold) 30 | beta <- output$optsol 31 | iter <- output$iter 32 | if (isgiven==1){ 33 | bound.stop <- 1 34 | } 35 | else{ 36 | if (try.no==1){ 37 | if (iter == (maxiter+1)){ 38 | incr <- 1; 39 | bound <- bound*resol; 40 | } else { 41 | incr <- 0; 42 | bound <- bound/resol; 43 | } 44 | } 45 | if (try.no > 1){ 46 | if ((incr == 1)&&(iter == (maxiter+1))){ 47 | bound <- bound*resol; 48 | } 49 | if ((incr == 1)&&(iter < (maxiter+1))){ 50 | bound.stop <- 1; 51 | } 52 | if ((incr == 0)&&(iter < (maxiter+1))){ 53 | bound <- bound/resol; 54 | } 55 | if ((incr == 0)&&(iter == (maxiter+1))){ 56 | bound <- bound*resol; 57 | beta <- last.beta; 58 | bound.stop <- 1; 59 | } 60 | } 61 | } 62 | try.no <- try.no+1 63 | } 64 | M[i,] <- beta; 65 | } 66 | return(M) 67 | } 68 | 69 | InverseLinftyOneRow <- function ( sigma, i, bound, maxiter=50, threshold=1e-10) { 70 | p <- nrow(sigma); 71 | rho <- max(abs(sigma[i,-i])) / sigma[i,i]; 72 | bound0 <- rho/(1+rho); 73 | beta <- rep(0,p); 74 | 75 | #if (bound >= bound0){ 76 | # beta[i] <- (1-bound0)/sigma[i,i]; 77 | # returnlist <- list("optsol" = beta, "iter" = 0); 78 | # return(returnlist); 79 | #} 80 | 81 | diff.norm2 <- 1; 82 | last.norm2 <- 1; 83 | iter <- 1; 84 | iter.old <- 1; 85 | beta[i] <- (1-bound0)/sigma[i,i]; 86 | beta.old <- beta; 87 | sigma.tilde <- sigma; 88 | diag(sigma.tilde) <- 0; 89 | vs <- -sigma.tilde%*%beta; 90 | 91 | while ((iter <= maxiter) && (diff.norm2 >= threshold*last.norm2)){ 92 | 93 | for (j in 1:p){ 94 | oldval <- beta[j]; 95 | v <- vs[j]; 96 | if (j==i) 97 | v <- v+1; 98 | beta[j] <- SoftThreshold(v,bound)/sigma[j,j]; 99 | if (oldval != beta[j]){ 100 | vs <- vs + (oldval-beta[j])*sigma.tilde[,j]; 101 | } 102 | } 103 | 104 | iter <- iter + 1; 105 | if (iter==2*iter.old){ 106 | d <- beta - beta.old; 107 | diff.norm2 <- sqrt(sum(d*d)); 108 | last.norm2 <-sqrt(sum(beta*beta)); 109 | iter.old <- iter; 110 | beta.old <- beta; 111 | #if (iter>10) 112 | # vs <- -sigma.tilde%*%beta; 113 | } 114 | 115 | # print(c(iter, maxiter, diff.norm2, threshold * last.norm2, threshold, bound)) 116 | 117 | } 118 | 119 | returnlist <- list("optsol" = beta, "iter" = iter) 120 | return(returnlist) 121 | } 122 | 123 | SoftThreshold <- function( x, lambda ) { 124 | # 125 | # Standard soft thresholding 126 | # 127 | if (x>lambda){ 128 | return (x-lambda);} 129 | else { 130 | if (x< (-lambda)){ 131 | return (x+lambda);} 132 | else { 133 | return (0); } 134 | } 135 | } 136 | 137 | 138 | ### Test 139 | 140 | n = 100; p = 250 141 | 142 | X = matrix(rnorm(n * p), n, p) 143 | S = t(X) %*% X / n 144 | 145 | debiasing_bound = 0.2 146 | 147 | tol = 1.e-12 148 | 149 | rows = as.integer(c(1:2)) 150 | 151 | A1 = debiasingMatrix(S, FALSE, n, rows, bound=debiasing_bound, max_iter=1000, kkt_tol=tol, objective_tol=tol, parameter_tol=tol, linesearch=FALSE) 152 | A2 = debiasingMatrix(S / n, FALSE, n, rows, bound=debiasing_bound, max_iter=1000, kkt_tol=tol, objective_tol=tol, parameter_tol=tol, linesearch=FALSE) 153 | B1 = debiasingMatrix(X, TRUE, n, rows, bound=debiasing_bound, max_iter=1000, kkt_tol=tol, objective_tol=tol, parameter_tol=tol, linesearch=FALSE) 154 | B2 = debiasingMatrix(X / sqrt(n), TRUE, n, rows, bound=debiasing_bound, max_iter=1000, kkt_tol=tol, objective_tol=tol, parameter_tol=tol, linesearch=FALSE) 155 | 156 | C1 = InverseLinfty(S, n, bound=debiasing_bound, maxiter=1000)[rows,] 157 | C2 = InverseLinfty(S / n, n, bound=debiasing_bound, maxiter=1000)[rows,] 158 | 159 | par(mfrow=c(2,3)) 160 | 161 | plot(A1[1,], C1[1,]) 162 | plot(A1[1,], B1[1,]) 163 | plot(B1[1,], C1[1,]) 164 | 165 | plot(A1[1,], A2[1,]) 166 | plot(B1[1,], B2[1,]) 167 | plot(C1[1,], C2[1,]) 168 | 169 | print(c('A', sum(A1[1,] == 0))) 170 | print(c('B', sum(B1[1,] == 0))) 171 | print(c('C', sum(C1[1,] == 0))) 172 | 173 | ## Are our points feasible 174 | 175 | feasibility = function(S, soln, j, debiasing_bound) { 176 | p = nrow(S) 177 | E = rep(0, p) 178 | E[j] = 1 179 | G = S %*% soln - E 180 | return(c(max(abs(G)), debiasing_bound)) 181 | } 182 | 183 | print(c('feasibility A', feasibility(S, A1[1,], 1, debiasing_bound))) 184 | print(c('feasibility B', feasibility(S, B1[1,], 1, debiasing_bound))) 185 | print(c('feasibility C', feasibility(S, C1[1,], 1, debiasing_bound))) 186 | 187 | active_KKT = function(S, soln, j, debiasing_bound) { 188 | p = nrow(S) 189 | E = rep(0, p) 190 | E[j] = 1 191 | G = S %*% soln - E 192 | print(which(soln != 0)) 193 | print(G[j]) 194 | return(c(G[soln != 0] * sign(soln)[soln != 0], debiasing_bound)) 195 | } 196 | 197 | print(c('active_KKT A', active_KKT(S, A1[1,], 1, debiasing_bound))) 198 | print(c('active_KKT B', active_KKT(S, B1[1,], 1, debiasing_bound))) 199 | print(c('active_KKT C', active_KKT(S, C1[1,], 1, debiasing_bound))) 200 | 201 | 202 | print(summary(lm(A1[1,] ~ C1[1,]))) -------------------------------------------------------------------------------- /tests/lee_high_dim/test_lee.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | library(glmnet) 3 | 4 | # testing Lee et al in high dimensional setting 5 | # uses debiasing matrix for type=full 6 | 7 | test_lee = function(seed=1, outfile=NULL, type="full", loss="ls", lambda_frac=0.7, 8 | nrep=50, n=200, p=800, s=30, rho=0.){ 9 | 10 | snr = sqrt(2*log(p)/n) 11 | 12 | set.seed(seed) 13 | construct_ci=TRUE 14 | penalty_factor = rep(1, p) 15 | 16 | pvalues = NULL 17 | sel_intervals=NULL 18 | sel_coverages=NULL 19 | sel_lengths=NULL 20 | 21 | FDR_sample = NULL 22 | power_sample=NULL 23 | 24 | for (i in 1:nrep){ 25 | if (loss=="ls"){ 26 | data = selectiveInference:::gaussian_instance(n=n, p=p, s=s, rho=rho, sigma=1, snr=snr) 27 | } else if (loss=="logit"){ 28 | data = selectiveInference:::logistic_instance(n=n, p=p, s=s, rho=rho, snr=snr) 29 | } 30 | X=data$X 31 | y=data$y 32 | beta=data$beta 33 | cat("true nonzero:", which(beta!=0), "\n") 34 | 35 | #CV = cv.glmnet(X, y, standardize=FALSE, intercept=FALSE, family=selectiveInference:::family_label(loss)) 36 | #sigma_est=selectiveInference:::estimate_sigma(X,y,coef(CV, s="lambda.min")[-1]) # sigma via Reid et al. 37 | #sigma_est=1 38 | sigma_est = selectiveInference:::estimate_sigma_data_spliting(X,y) 39 | print(c("sigma est", sigma_est)) 40 | 41 | # lambda = CV$lambda[which.min(CV$cvm+rnorm(length(CV$cvm))/sqrt(n))] # lambda via randomized cv 42 | lambda = lambda_frac*selectiveInference:::theoretical.lambda(X, loss, sigma_est) # theoretical lambda 43 | 44 | lasso = glmnet(X, y, family=selectiveInference:::family_label(loss), alpha=1, standardize=FALSE, intercept=FALSE, thresh=1e-12) 45 | soln = as.numeric(coef(lasso,x=X,y=y, family=selectiveInference:::family_label(loss), s=lambda, exact=TRUE)[-1]) 46 | 47 | PVS = selectiveInference:::fixedLassoInf(X,y,soln, intercept=FALSE, lambda*n, family=selectiveInference:::family_label(loss), 48 | type=type, sigma=sigma_est) 49 | 50 | abs_soln = abs(soln) 51 | beta_threshold = abs_soln[order(abs_soln,decreasing=TRUE)][length(PVS$pv)] 52 | active_vars = which(abs_soln>=beta_threshold) 53 | cat("nactive:", length(active_vars), "\n") 54 | cat("active vars:", active_vars, "\n") 55 | 56 | pvalues = c(pvalues, PVS$pv) 57 | sel_intervals = cbind(sel_intervals, t(PVS$ci)) 58 | 59 | if (length(pvalues)>0){ 60 | plot(ecdf(pvalues)) 61 | abline(0,1) 62 | } 63 | 64 | if (construct_ci && length(active_vars)>0){ 65 | sel_coverages=c(sel_coverages, selectiveInference:::compute_coverage(t(PVS$ci), beta[active_vars])) 66 | sel_lengths=c(sel_lengths, as.vector(PVS$ci[,2]-PVS$ci[,1])) 67 | print(c("selective coverage:", mean(sel_coverages))) 68 | print(c("selective length mean:", mean(sel_lengths))) 69 | print(c("selective length median:", median(sel_lengths))) 70 | } 71 | 72 | mc = selectiveInference:::selective.plus.BH(beta, active_vars, PVS$pv, q=0.2) 73 | FDR_sample=c(FDR_sample, mc$FDR) 74 | power_sample=c(power_sample, mc$power) 75 | 76 | if (length(FDR_sample)>0){ 77 | print(c("FDR:", mean(FDR_sample))) 78 | print(c("power:", mean(power_sample))) 79 | } 80 | } 81 | 82 | if (is.null(outfile)){ 83 | outfile=paste("lee_", type, ".rds", sep="") 84 | } 85 | 86 | saveRDS(list(sel_intervals=sel_intervals, sel_coverages=sel_coverages, sel_lengths=sel_lengths, 87 | pvalues=pvalues, 88 | FDR_sample=FDR_sample, power_sample=power_sample, 89 | n=n, p=p, s=s, snr=snr, rho=rho, type=type), file=outfile) 90 | 91 | return(list(pvalues=pvalues)) 92 | } 93 | 94 | test_lee() 95 | 96 | 97 | 98 | -------------------------------------------------------------------------------- /tests/liu_high_dim_full/test_liu_full.R: -------------------------------------------------------------------------------- 1 | library(gglasso) 2 | library(MASS) 3 | library(selectiveInference) 4 | library(glmnet) 5 | 6 | # testing Liu et al type=full in high dimensional settings -- uses debiasing matrix 7 | 8 | test_liu_full = function(seed=1, outfile=NULL, family="gaussian", lambda_frac=0.7, 9 | nrep=50, n=200, p=500, s=20, rho=0.){ 10 | 11 | snr = sqrt(2*log(p)/n) 12 | 13 | set.seed(seed) 14 | construct_ci=TRUE 15 | penalty_factor = rep(1, p) 16 | 17 | pvalues=NULL 18 | sel_intervals=NULL 19 | sel_coverages=NULL 20 | sel_lengths=NULL 21 | naive_pvalues=NULL 22 | naive_intervals=NULL 23 | naive_coverages=NULL 24 | naive_lengths=NULL 25 | 26 | FDR_sample = NULL 27 | power_sample=NULL 28 | 29 | for (i in 1:nrep){ 30 | 31 | if (family=="gaussian"){ 32 | sigma=1 33 | data = selectiveInference:::gaussian_instance(n=n, p=p, s=s, rho=rho, sigma=sigma, snr=snr) 34 | loss = 'ls' 35 | } else if (family=='binomial'){ 36 | sigma=1 37 | data = selectiveInference:::logistic_instance(n=n, p=p, s=s, rho=rho, snr=snr) 38 | loss = 'logit' 39 | } 40 | 41 | X=data$X 42 | y=data$y 43 | beta=data$beta 44 | cat("true nonzero:", which(beta!=0), "\n") 45 | 46 | # CV = cv.glmnet(X, y, standardize=FALSE, intercept=FALSE, family=selectiveInference:::family_label(loss)) 47 | # sigma_est=selectiveInference:::estimate_sigma(X,y,coef(CV, s="lambda.min")[-1]) # sigma via Reid et al. 48 | sigma_est=sigma 49 | #sigma_est = selectiveInference:::estimate_sigma_data_spliting(X,y) 50 | print(c("sigma est", sigma_est)) 51 | 52 | lambda = lambda_frac*selectiveInference:::theoretical.lambda(X, loss, sigma_est) # theoretical lambda 53 | print(c("lambda", lambda)) 54 | 55 | soln = selectiveInference:::solve_problem_glmnet(X, y, lambda, penalty_factor=penalty_factor, family=family) 56 | PVS = ROSI(X, 57 | y, 58 | soln, 59 | lambda=lambda*n, 60 | penalty_factor=penalty_factor, 61 | dispersion=sigma_est^2, 62 | family=family, 63 | solver="QP", 64 | construct_ci=construct_ci, 65 | debiasing_method="JM", 66 | verbose=TRUE) 67 | 68 | active_vars=PVS$active_set 69 | cat("active_vars:",active_vars,"\n") 70 | pvalues = c(pvalues, PVS$pvalues) 71 | 72 | naive_Z = PVS$estimate / PVS$std_err 73 | naive_P = pnorm(naive_Z) 74 | naive_P = 2 * pmin(naive_P, 1 - naive_P) 75 | naive_pvalues = c(naive_pvalues, naive_P) 76 | sel_intervals = rbind(sel_intervals, PVS$intervals) # matrix with two rows 77 | naive_Q = qnorm(0.95) 78 | naive_int = cbind(PVS$estimate - naive_Q * PVS$std_err, PVS$estimate + naive_Q * PVS$std_err) 79 | naive_int[is.na(PVS$pvalues),] = NA 80 | naive_intervals = rbind(naive_intervals, naive_int) 81 | print('naive intervals') 82 | print(naive_intervals) 83 | if (length(pvalues)>0){ 84 | plot(ecdf(pvalues)) 85 | lines(ecdf(naive_pvalues), col="red") 86 | abline(0,1) 87 | } 88 | 89 | if (construct_ci && length(active_vars)>0){ 90 | 91 | sel_coverages=c(sel_coverages, selectiveInference:::compute_coverage(PVS$intervals, beta[active_vars])) 92 | naive_coverages=c(naive_coverages, selectiveInference:::compute_coverage(naive_int, beta[active_vars])) 93 | sel_lengths=c(sel_lengths, as.vector(naive_int[,2]-naive_int[,1])) 94 | naive_lengths=c(naive_lengths, as.vector(PVS$naive_intervals[,2]-PVS$naive_intervals[,1])) 95 | #cat("sel cov", sel_coverages, "\n") 96 | print(c("selective coverage:", mean(sel_coverages, na.rm=TRUE))) 97 | NA_sel = is.na(sel_coverages) 98 | naive_coverages[NA_sel] = NA 99 | print(c("naive coverage:", mean(naive_coverages, na.rm=TRUE))) 100 | print(c("selective length mean:", mean(sel_lengths, na.rm=TRUE))) 101 | print(c("selective length median:", median(sel_lengths, na.rm=TRUE))) 102 | naive_lengths[NA_sel] = NA 103 | print(c("naive length mean:", mean(naive_lengths, na.rm=TRUE))) 104 | print(c("naive length median:", median(naive_lengths, na.rm=TRUE))) 105 | } 106 | 107 | mc = selectiveInference:::selective.plus.BH(beta, active_vars, PVS$pvalues, q=0.2) 108 | FDR_sample=c(FDR_sample, mc$FDR) 109 | power_sample=c(power_sample, mc$power) 110 | 111 | if (length(FDR_sample)>0){ 112 | print(c("FDR:", mean(FDR_sample))) 113 | print(c("power:", mean(power_sample))) 114 | } 115 | } 116 | 117 | if (is.null(outfile)){ 118 | outfile="liu_full.rds" 119 | } 120 | 121 | saveRDS(list(sel_intervals=sel_intervals, sel_coverages=sel_coverages, sel_lengths=sel_lengths, 122 | naive_intervals=naive_intervals, naive_coverages=naive_coverages, naive_lengths=naive_lengths, 123 | pvalues=pvalues, naive_pvalues=naive_pvalues, 124 | FDR_sample=FDR_sample, power_sample=power_sample, 125 | n=n, p=p, s=s, snr=snr, rho=rho), file=outfile) 126 | 127 | return(list(pvalues=pvalues, naive_pvalues=naive_pvalues)) 128 | } 129 | 130 | test_liu_full() 131 | 132 | -------------------------------------------------------------------------------- /tests/randomized/nonnull.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | set.seed(32103) 3 | 4 | # parameters 5 | 6 | n=20; p=12; nsim=50 7 | sigma=1; alpha=.1; lam=0.04 8 | 9 | # design 10 | 11 | X=matrix(rnorm(n*p),n,p) 12 | X=scale(X,TRUE,TRUE) / sqrt(n-1) 13 | 14 | # truth 15 | 16 | btrue=c(1,4,-4,rep(0,p-3)) 17 | 18 | sign=rep(NA,p) 19 | ci=ci0=ci2=ci4=ci5=ci6=vlims0=array(NA,c(p,2,nsim)) 20 | 21 | betaall=matrix(NA,nsim,p) 22 | btruepart=matrix(NA,p,nsim) 23 | mc2=matrix(NA,nsim,p) 24 | zalpha=-qnorm(alpha/2) 25 | 26 | 27 | seeds=sample(1:99999, size=nsim) 28 | 29 | for(ii in 1:nsim){ 30 | set.seed(seeds[ii]) 31 | mutrue = X%*%btrue 32 | y = mutrue+sigma*rnorm(n) 33 | y = y - mean(y) 34 | 35 | if (p>1) { 36 | G = glmnet(X,y,standardize=FALSE) 37 | beta=as.numeric(coef(G, s=lam, exact=TRUE, x=X, y=y))[-1] 38 | } else if (p==1) { 39 | coef=lsfit(x,y)$coef[2] 40 | beta=sign(coef)*(abs(coef)-n*lam)*(abs(coef)>n*lam) 41 | } 42 | 43 | # any active 44 | if (sum(beta!=0) > 0){ 45 | betaall[ii,]=beta 46 | a=lsfit(X[,beta!=0], y) 47 | aa=ls.diag(a) 48 | bhat=a$coef[-1] 49 | bhat0=a$coef[1] 50 | act=which(beta!=0) 51 | se=aa$std.err[-1] 52 | btruepart[,ii]=0 53 | btruepart[act,ii]=lsfit(X[,act,drop=F],mutrue)$coef[-1] 54 | 55 | #naive intervals 56 | ci0[beta!=0,1,ii]=bhat-zalpha*se 57 | ci0[beta!=0,2,ii]=bhat+zalpha*se 58 | 59 | #bonf-adj naive 60 | alpha4=alpha/p 61 | zalpha4=-qnorm(alpha4/2) 62 | ci4[beta!=0,1,ii]=bhat-zalpha4*se 63 | ci4[beta!=0,2,ii]=bhat+zalpha4*se 64 | 65 | #lee et al intervals 66 | lee = fixedLassoInf(X, 67 | y, 68 | beta, 69 | lam*n, 70 | alpha=alpha, 71 | family='gaussian', 72 | type='partial', 73 | sigma=sigma) 74 | ci_lee = matrix(NA, p, 2) 75 | ci_lee[lee$vars,] = lee$ci 76 | ci[,,ii] = ci_lee 77 | 78 | #randomized 79 | 80 | rand_lasso_soln = randomizedLasso(X, y, n*lam, noise_scale=0.5*sigma, ridge_term=0.5*sigma/sqrt(n)) 81 | rand_E = rand_lasso_soln$active_set 82 | X_rand_E = X[,rand_E,drop=FALSE] 83 | rand_target = coef(glm(y~X_rand_E-1)) 84 | cov_rand_E = solve(t(X_rand_E) %*% X_rand_E) * sigma^2 85 | cross_cov = matrix(0, p, length(rand_E)) 86 | cross_cov[1:length(rand_E),1:length(rand_E)] = cov_rand_E 87 | targets = list(observed_target=rand_target, 88 | cov_target=cov_rand_E, 89 | crosscov_target_internal=cross_cov) 90 | rand_inf = randomizedLassoInf(rand_lasso_soln, nsample=5000, burnin=1000, targets=targets) 91 | ci5[rand_lasso_soln$act,1,ii] = rand_inf$ci[,1] 92 | ci5[rand_lasso_soln$act,2,ii] = rand_inf$ci[,2] 93 | } 94 | 95 | 96 | 97 | 98 | mc0=mean(ci0[,1,1:ii]>btruepart[,1:ii] | ci0[,2,1:ii]btruepart[,1:ii] | ci[,2,1:ii]btruepart[,1:ii] | ci4[,2,1:ii]btruepart[,1:ii] | ci5[,2,1:ii]0){ 15 | beta[1:s] = seq(3, 6, length.out=s) 16 | } 17 | beta = sample(beta) 18 | if (random_signs==TRUE & s>0){ 19 | signs = sample(c(-1,1), s, replace = TRUE) 20 | beta = beta * signs 21 | } 22 | mu = X %*% beta 23 | if (family=="gaussian"){ 24 | y = mu + rnorm(n)*sigma 25 | } else if (family=="binomial"){ 26 | prob = exp(mu)/(1+exp(mu)) 27 | y= rbinom(n,1, prob) 28 | } 29 | result = list(X=X,y=y,beta=beta) 30 | return(result) 31 | } 32 | 33 | 34 | 35 | 36 | test_randomized_lasso = function(n=100,p=200,s=0){ 37 | set.seed(1) 38 | data = get_instance(n=n,p=p,s=s, rho=0.3, sigma=1, family="binomial") 39 | X=data$X 40 | y=data$y 41 | lam = 2. 42 | noise_scale = 0.5 43 | ridge_term = 1./sqrt(n) 44 | result = selectiveInference:::randomizedLasso(X, y, lam, noise_scale, ridge_term) 45 | print(result$soln) 46 | print(length(which(result$soln!=0))) 47 | print(result$observed_opt_state) # compared with python code 48 | } 49 | 50 | test_randomized_logistic = function(n=100,p=20,s=0){ 51 | set.seed(1) 52 | data = get_instance(n=n,p=p,s=s, rho=0.3, sigma=1, family="binomial") 53 | X=data$X 54 | y=data$y 55 | lam = 0.5 56 | noise_scale = 0.5 57 | ridge_term = 1./sqrt(n) 58 | set.seed(1) 59 | perturb = rnorm(p)*noise_scale 60 | result = selectiveInference:::solve_logistic(X,y,lam, ridge_term, perturb) 61 | print(result$soln) 62 | print(length(which(result$soln!=0))) 63 | } 64 | 65 | #test_randomized_logistic() 66 | 67 | 68 | test_KKT=function(){ 69 | set.seed(1) 70 | n=200 71 | p=100 72 | data = gaussian_instance(n=n,p=p,s=0, rho=0.3, sigma=3) 73 | X=data$X 74 | y=data$y 75 | lam = 2. 76 | noise_scale = 0.5 77 | ridge_term = 1./sqrt(n) 78 | result = selectiveInference:::randomizedLasso(X,y,lam, noise_scale, ridge_term) 79 | print("check KKT") 80 | opt_linear = result$optimization_transform$linear_term 81 | opt_offset = result$optimization_transform$offset_term 82 | observed_opt_state=result$observed_opt_state 83 | #print(dim(opt_linear)) 84 | #print(opt_offset) 85 | #print(result$perturb) 86 | print(opt_linear %*% observed_opt_state+opt_offset+result$observed_raw-result$perturb) ## should be zero 87 | } 88 | 89 | 90 | collect_results = function(n,p,s, nsim=100, level=0.9, 91 | family = "gaussian", 92 | condition_subgrad=TRUE, 93 | type="full", 94 | lam=1.2){ 95 | 96 | rho=0. 97 | sigma=1 98 | sample_pvalues = c() 99 | sample_coverage = c() 100 | for (i in 1:nsim){ 101 | data = get_instance(n=n,p=p,s=s, rho=rho, sigma=sigma, family=family) 102 | X=data$X 103 | y=data$y 104 | 105 | rand_lasso_soln = selectiveInference:::randomizedLasso(X, 106 | y, 107 | lam, 108 | family=family, 109 | condition_subgrad=condition_subgrad) 110 | 111 | targets=selectiveInference:::compute_target(rand_lasso_soln,type=type) 112 | print(targets$construct_pvalues) 113 | result = selectiveInference:::randomizedLassoInf(rand_lasso_soln, 114 | targets=targets, 115 | sampler="norejection", #"adaptMCMC", # 116 | level=level, 117 | burnin=1000, 118 | nsample=5000) 119 | if (length(result$pvalues)>0){ 120 | true_beta = data$beta[rand_lasso_soln$active_set] 121 | coverage = rep(0, nrow(result$ci)) 122 | for (i in 1:nrow(result$ci)){ 123 | if (result$ci[i,1]true_beta[i]){ 124 | coverage[i]=1 125 | } 126 | print(paste("ci", toString(result$ci[i,]))) 127 | } 128 | sample_pvalues = c(sample_pvalues, result$pvalues) 129 | sample_coverage = c(sample_coverage, coverage) 130 | print(paste("coverage", mean(sample_coverage))) 131 | } 132 | } 133 | if (length(sample_coverage)>0){ 134 | print(paste("coverage", mean(sample_coverage))) 135 | jpeg('pivots.jpg') 136 | plot(ecdf(sample_pvalues), xlim=c(0,1), main="Empirical CDF of null p-values", xlab="p-values", ylab="ecdf") 137 | abline(0, 1, lty=2) 138 | dev.off() 139 | } 140 | } 141 | 142 | set.seed(1) 143 | collect_results(n=100, p=20, s=0, lam=1.) 144 | 145 | -------------------------------------------------------------------------------- /tests/randomized/test_randomized.R: -------------------------------------------------------------------------------- 1 | library(MASS) 2 | library(selectiveInference) 3 | library(glmnet) 4 | 5 | 6 | test_randomized = function(seed=1, outfile=NULL, type="partial", loss="ls", lambda_frac=0.7, 7 | nrep=50, n=200, p=800, s=30, rho=0.){ 8 | 9 | snr = sqrt(2*log(p)/n) 10 | 11 | set.seed(seed) 12 | construct_ci=TRUE 13 | penalty_factor = rep(1, p) 14 | 15 | pvalues = NULL 16 | sel_intervals=NULL 17 | sel_coverages=NULL 18 | sel_lengths=NULL 19 | 20 | FDR_sample = NULL 21 | power_sample=NULL 22 | 23 | for (i in 1:nrep){ 24 | 25 | if (loss=="ls"){ 26 | data = selectiveInference:::gaussian_instance(n=n, p=p, s=s, rho=rho, sigma=1, snr=snr) 27 | } else if (loss=="logit"){ 28 | data = selectiveInference:::logistic_instance(n=n, p=p, s=s, rho=rho, snr=snr) 29 | } 30 | 31 | X=data$X 32 | y=data$y 33 | beta=data$beta 34 | cat("true nonzero:", which(beta!=0), "\n") 35 | 36 | #CV = cv.glmnet(X, y, standardize=FALSE, intercept=FALSE, family=selectiveInference:::family_label(loss)) 37 | #sigma_est=selectiveInference:::estimate_sigma(X,y,coef(CV, s="lambda.min")[-1]) # sigma via Reid et al. 38 | sigma_est=1 39 | #sigma_est = selectiveInference:::estimate_sigma_data_spliting(X,y) 40 | print(c("sigma est", sigma_est)) 41 | 42 | # lambda = CV$lambda[which.min(CV$cvm+rnorm(length(CV$cvm))/sqrt(n))] # lambda via randomized cv 43 | lambda = lambda_frac*selectiveInference:::theoretical.lambda(X, loss, sigma_est) # theoretical lambda 44 | 45 | 46 | rand_lasso_soln = selectiveInference:::randomizedLasso(X, 47 | y, 48 | lambda*n, 49 | family=selectiveInference:::family_label(loss)) 50 | 51 | targets=selectiveInference:::compute_target(rand_lasso_soln, type=type, sigma_est=sigma_est) 52 | 53 | PVS = selectiveInference:::randomizedLassoInf(rand_lasso_soln, 54 | targets=targets, 55 | sampler = "norejection", #"adaptMCMC", # 56 | level=0.9, 57 | burnin=1000, 58 | nsample=10000) 59 | active_vars=rand_lasso_soln$active_set 60 | cat("active_vars:",active_vars,"\n") 61 | pvalues = c(pvalues, PVS$pvalues) 62 | sel_intervals = rbind(sel_intervals, PVS$ci) # matrix with two rows 63 | 64 | 65 | if (length(pvalues)>0){ 66 | plot(ecdf(pvalues)) 67 | #lines(ecdf(naive_pvalues), col="red") 68 | abline(0,1) 69 | } 70 | 71 | if (construct_ci && length(active_vars)>0){ 72 | 73 | sel_coverages=c(sel_coverages, selectiveInference:::compute_coverage(PVS$ci, beta[active_vars])) 74 | sel_lengths=c(sel_lengths, as.vector(PVS$ci[,2]-PVS$ci[,1])) 75 | print(c("selective coverage:", mean(sel_coverages))) 76 | print(c("selective length mean:", mean(sel_lengths))) 77 | print(c("selective length median:", median(sel_lengths))) 78 | #naive_coverages=c(naive_coverages, selectiveInference:::compute_coverage(PVS$naive_intervals, beta[active_vars])) 79 | #naive_lengths=c(naive_lengths, as.vector(PVS$naive_intervals[2,]-PVS$naive_intervals[1,])) 80 | #print(c("naive coverage:", mean(naive_coverages))) 81 | #print(c("naive length mean:", mean(naive_lengths))) 82 | #print(c("naive length median:", median(naive_lengths))) 83 | } 84 | 85 | mc = selectiveInference:::selective.plus.BH(beta, active_vars, PVS$pvalues, q=0.2) 86 | FDR_sample=c(FDR_sample, mc$FDR) 87 | power_sample=c(power_sample, mc$power) 88 | 89 | if (length(FDR_sample)>0){ 90 | print(c("FDR:", mean(FDR_sample))) 91 | print(c("power:", mean(power_sample))) 92 | } 93 | } 94 | 95 | if (is.null(outfile)){ 96 | outfile=paste("randomized_", type, ".rds", sep="") 97 | } 98 | 99 | saveRDS(list(sel_intervals=sel_intervals, sel_coverages=sel_coverages, sel_lengths=sel_lengths, 100 | pvalues=pvalues, 101 | FDR_sample=FDR_sample, power_sample=power_sample, 102 | n=n,p=p, s=s, snr=snr, rho=rho, type=type), file=outfile) 103 | 104 | return(list(pvalues=pvalues)) 105 | } 106 | 107 | test_randomized(n=100, p=20, s=4) 108 | 109 | 110 | -------------------------------------------------------------------------------- /tests/randomized/test_randomized_simple.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | 3 | smoke_test = function() { 4 | n = 100; p = 50 5 | X = matrix(rnorm(n * p), n, p) 6 | y = rnorm(n) 7 | lam = 20 / sqrt(n) 8 | noise_scale = 0.01 * sqrt(n) 9 | ridge_term = .1 / sqrt(n) 10 | selectiveInference:::randomizedLasso(X, y, lam, noise_scale, ridge_term) 11 | } 12 | 13 | A = smoke_test() 14 | 15 | sampler_test = function() { 16 | 17 | n = 100; p = 50 18 | X = matrix(rnorm(n * p), n, p) 19 | y = rnorm(n) 20 | lam = 20 / sqrt(n) 21 | noise_scale = 0.01 * sqrt(n) 22 | ridge_term = .1 / sqrt(n) 23 | obj = selectiveInference:::randomizedLasso(X, y, lam, noise_scale, ridge_term) 24 | S = selectiveInference:::sample_opt_variables(obj, jump_scale=rep(1/sqrt(n), p), nsample=10000) 25 | return(S$samples[2001:10000,]) 26 | } 27 | B = sampler_test() 28 | 29 | gaussian_density_test = function() { 30 | 31 | noise_scale = 10. 32 | random_lasso = smoke_test() 33 | p = nrow(random_lasso$internal_transform$linear_term) 34 | internal_state = matrix(rnorm(p * 20), p, 20) 35 | optimization_state = matrix(rnorm(p * 20), p, 20) 36 | offset = rnorm(p) 37 | 38 | V1 = selectiveInference:::log_density_gaussian_(noise_scale, 39 | random_lasso$internal_transform$linear_term, 40 | internal_state, 41 | random_lasso$optimization_transform$linear_term, 42 | optimization_state, 43 | offset) 44 | A1 = random_lasso$internal_transform$linear_term 45 | A2 = random_lasso$optimization_transform$linear_term 46 | arg = A1 %*% internal_state + A2 %*% optimization_state + offset 47 | V2 = -apply(arg^2, 2, sum) / (2 * noise_scale^2) 48 | print(sqrt(sum((V1-V2)^2) / sum(V1^2))) 49 | 50 | U1 = selectiveInference:::log_density_gaussian_conditional_(noise_scale, 51 | random_lasso$optimization_transform$linear_term, 52 | optimization_state, 53 | offset) 54 | arg = A2 %*% optimization_state + offset 55 | U2 = -apply(arg^2, 2, sum) / (2 * noise_scale^2) 56 | print(sqrt(sum((U1-U2)^2) / sum(U1^2))) 57 | 58 | # test that a single column matrix works -- numeric should not 59 | 60 | print(selectiveInference:::log_density_gaussian_conditional_(noise_scale, 61 | random_lasso$optimization_transform$linear_term, 62 | optimization_state[,1,drop=FALSE], 63 | offset)) 64 | print(selectiveInference:::log_density_gaussian_(noise_scale, 65 | random_lasso$internal_transform$linear_term, 66 | internal_state[,1,drop=FALSE], 67 | random_lasso$optimization_transform$linear_term, 68 | optimization_state[,1,drop=FALSE], 69 | offset)) 70 | 71 | } 72 | 73 | gaussian_density_test() 74 | 75 | laplace_density_test = function() { 76 | 77 | noise_scale = 10. 78 | random_lasso = smoke_test() 79 | p = nrow(random_lasso$internal_transform$linear_term) 80 | internal_state = matrix(rnorm(p * 20), p, 20) 81 | optimization_state = matrix(rnorm(p * 20), p, 20) 82 | offset = rnorm(p) 83 | 84 | V1 = selectiveInference:::log_density_laplace_(noise_scale, 85 | random_lasso$internal_transform$linear_term, 86 | internal_state, 87 | random_lasso$optimization_transform$linear_term, 88 | optimization_state, 89 | offset) 90 | A1 = random_lasso$internal_transform$linear_term 91 | A2 = random_lasso$optimization_transform$linear_term 92 | arg = A1 %*% internal_state + A2 %*% optimization_state + offset 93 | V2 = -apply(abs(arg), 2, sum) / noise_scale 94 | print(sqrt(sum((V1-V2)^2) / sum(V1^2))) 95 | 96 | U1 = selectiveInference:::log_density_laplace_conditional_(noise_scale, 97 | random_lasso$optimization_transform$linear_term, 98 | optimization_state, 99 | offset) 100 | arg = A2 %*% optimization_state + offset 101 | U2 = -apply(abs(arg), 2, sum) / noise_scale 102 | print(sqrt(sum((U1-U2)^2) / sum(U1^2))) 103 | 104 | # test that a single column matrix works -- numeric should not 105 | 106 | print(selectiveInference:::log_density_laplace_conditional_(noise_scale, 107 | random_lasso$optimization_transform$linear_term, 108 | optimization_state[,1,drop=FALSE], 109 | offset)) 110 | print(selectiveInference:::log_density_laplace_(noise_scale, 111 | random_lasso$internal_transform$linear_term, 112 | internal_state[,1,drop=FALSE], 113 | random_lasso$optimization_transform$linear_term, 114 | optimization_state[,1,drop=FALSE], 115 | offset)) 116 | 117 | } 118 | 119 | laplace_density_test() 120 | -------------------------------------------------------------------------------- /tests/randomized/test_sampler.R: -------------------------------------------------------------------------------- 1 | 2 | test_log_concave_sampler = function(){ 3 | samples = log_concave_sampler(negative_log_density= function(x){x^2/2}, 4 | grad_negative_log_density=function(x){x}, 5 | constraints = t(as.matrix(c(2,3))), 6 | observed = 2, nsamples=10000) 7 | mean(samples) 8 | hist(samples) 9 | } 10 | 11 | 12 | test_gaussian_sampler =function(){ 13 | samples = gaussian_sampler(1, 1, 1, 0,10000) 14 | mean(samples) 15 | hist(samples) 16 | } 17 | -------------------------------------------------------------------------------- /tests/randomized/timing.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | library(glmnet) 3 | set.seed(32) 4 | 5 | n=6000; p=50000 6 | 7 | coverage = c() 8 | for (i in 1:100) { 9 | print("creating X") 10 | print(system.time(x <- matrix(rnorm(n*p),n,p))) 11 | print(system.time(x <- scale(x,T,T)/sqrt(n-1))) 12 | print('running glmnet') 13 | y=rnorm(n) 14 | print(system.time(G <- glmnet(x,y,intercept=F,standardize=F))) 15 | lam=G$lam[5] #for p< 1000 16 | lam=G$lam[10] #for p=1000 17 | lam=G$lam[2] #for p=50,000 18 | print("solving randomized LASSO") 19 | print(system.time(rand_lasso <- randomizedLasso(x, y, n*lam))) 20 | print(rand_lasso$active_set) 21 | print("inference for randomizedLasso") 22 | tim=system.time(rand_lasso_inf<-randomizedLassoInf(rand_lasso, sampler='norejection', nsample=20000, burnin=10000))[1] 23 | print(rand_lasso_inf$pvalues) 24 | print(names(rand_lasso_inf$pvalues)) 25 | print(rand_lasso_inf$ci) 26 | coverage = c(coverage, (rand_lasso_inf$ci[,1] <= 0) * (rand_lasso_inf$ci[,2] >= 0)) 27 | print(mean(coverage)) 28 | } -------------------------------------------------------------------------------- /tests/randomized/timing_smaller.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | library(glmnet) 3 | set.seed(32) 4 | 5 | # smaller data sets 6 | n=500; p=4000 7 | 8 | coverage = c() 9 | for (i in 1:100) { 10 | print("creating X") 11 | print(system.time(x <- matrix(rnorm(n*p),n,p))) 12 | print(system.time(x <- scale(x,T,T)/sqrt(n-1))) 13 | print('running glmnet') 14 | y=rnorm(n) 15 | print(system.time(G <- glmnet(x,y,intercept=F,standardize=F))) 16 | lam=G$lam[5] #for p< 1000 17 | lam=G$lam[10] #for p=1000 18 | lam=G$lam[2] #for p=50,000 19 | print("solving randomized LASSO") 20 | print(system.time(rand_lasso <- randomizedLasso(x, y, n*lam))) 21 | print("inference for randomizedLasso") 22 | print(system.time(rand_lasso_inf<-randomizedLassoInf(rand_lasso, sampler='norejection', nsample=15000, burnin=10000))) 23 | print(rand_lasso_inf$ci) 24 | coverage = c(coverage, (rand_lasso_inf$ci[,1] <= 0) * (rand_lasso_inf$ci[,2] >= 0)) 25 | print(mean(coverage)) 26 | } -------------------------------------------------------------------------------- /tests/test.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference,lib.loc="mylib") 2 | library(truncnorm) 3 | 4 | 5 | 6 | mytruncnorm = function(etay, vneg,vpos, etamu, sigma){ 7 | # From Sam Gross- uses exp approximation in extreme tails 8 | # if range is too many sds away from mu, then there 9 | # will be numerical errors from using truncnorm 10 | if(max(vneg-etamu,etamu-vpos)/sigma < 7){ 11 | return(ptruncnorm(etay, vneg, vpos, etamu, sigma)) 12 | } 13 | 14 | else{ 15 | 16 | return(1 - pexp(vpos-etay, etamu-vpos)/ pexp(vpos-vneg, etamu-vpos)) 17 | 18 | } 19 | } 20 | 21 | alpha=.1 22 | sigma=1.199 23 | sigma.eta=1.215 24 | vm=.4454 25 | vp=.5702 26 | etay=.5066 27 | del=1e-4 28 | gridfac=50 29 | fun = function(x,etay,vm,vp,sigma.eta) return(1-ptruncnorm(etay,vm,vp,x,sigma.eta)) 30 | lo=-Inf 31 | hi=Inf 32 | covlo=covhi=0 33 | if( min(etay-vm,vp-etay)>.05*sigma.eta){ 34 | xL=etay-gridfac*sigma.eta 35 | xR=etay+gridfac*sigma.eta 36 | lo = grid.search(fun,alpha/2,xL,xR,etay=etay,vm=vm,vp=vp,sigma.eta=sigma.eta) 37 | hi = grid.search(fun,1-alpha/2,xL,xR,etay=etay,vm=vm,vp=vp,sigma.eta=sigma.eta) 38 | 39 | covlo=fun(lo,etay,vm,vp,sigma.eta) 40 | covhi=1-fun(hi,etay,vm,vp,sigma.eta) 41 | } 42 | cat(c(lo,hi,covlo,covhi),fill=T) 43 | 44 | x=w=seq(xL,xR,length=10000) 45 | 46 | w=fun(x,etay,vm,vp,sigma.eta) 47 | 48 | plot(x,w) 49 | 0.4454098 0.5066348 0.5702267 1.199096 1.215243 0.1 50 50 | -------------------------------------------------------------------------------- /tests/test.categorical.R: -------------------------------------------------------------------------------- 1 | #library(selectiveInference) 2 | #library(lars) 3 | library(intervals) 4 | source("../selectiveInference/R/funs.groupfs.R") 5 | source("../selectiveInference/R/funs.quadratic.R") 6 | source("../selectiveInference/R/funs.common.R") 7 | 8 | set.seed(1) 9 | n <- 100 10 | G <- 10 11 | maxsteps <- 10 12 | snr <- 1 13 | niter <- 100 14 | 15 | check.mismatch <- function(fsfit, fit) { 16 | fsnames <- names(fsfit$coefficients) 17 | if (length(fsnames) > 0) { 18 | fsnames <- unique(substr(fsnames, 1, nchar(fsnames) - 1)) 19 | k <- length(fsnames) 20 | fitnames <- attr(fit, "varnames")[fit$action][1:(length(fit$action)-attr(fit, "aicstop"))] 21 | if (is.null(fit$sigma)) { 22 | aicdiff <- AIC(fsfit) - fit$log$AIC[k] 23 | } else { 24 | aicdiff <- extractAIC(fsfit, scale = fit$sigma)[2] - fit$log$AIC[k] 25 | } 26 | if (length(fitnames) !=k || any(fsnames != fitnames)) { 27 | print(paste("Mismatch at iteration", iter, ifelse(is.null(fit$sigma), "unknown", "known"))) 28 | print(fsnames) 29 | print(fitnames) 30 | return(list(count = 1, aicdiff = aicdiff)) 31 | } 32 | return(list(count = 0, aicdiff = aicdiff)) 33 | } 34 | return(list(count = 0, aicdiff = 0)) 35 | } 36 | 37 | print("Comparing step with groupfs on random categorical designs") 38 | umismatchcount <- kmismatchcount <- 0 39 | uaicdiffs <- kaicdiffs <- numeric(niter) 40 | for (iter in 1:niter) { 41 | rles <- 2 + rpois(G, 2) 42 | df <- data.frame(do.call(cbind, lapply(rles, function(g) { 43 | sample(LETTERS[1:g], n, replace = TRUE, prob = runif(g)) 44 | })), stringsAsFactors = TRUE) 45 | if (any(apply(df, 2, function(col) length(unique(col))) == 1)) next 46 | fd <- factorDesign(df) 47 | if (any(duplicated(fd$x, MARGIN = 2))) next 48 | y <- rnorm(n) 49 | x1 <- fd$x[, fd$index == 1] 50 | y <- y + x1 %*% c(snr, rep(0, ncol(x1) - 2), -snr) 51 | y <- y - mean(y) 52 | df$y <- y 53 | capture.output(fsfit <- step(lm(y ~ 0, df), direction="forward", scope = formula(lm(y~.-1, df)), steps = maxsteps), file = "/dev/null") 54 | fit <- groupfs(fd$x, df$y, fd$index, maxsteps = 10, intercept = F, center = F, normalize = F, aicstop = 1) 55 | mismatches <- check.mismatch(fsfit, fit) 56 | umismatchcount <- umismatchcount + mismatches$count 57 | uaicdiffs[iter] <- mismatches$aicdiff 58 | capture.output(fsfit <- step(lm(y ~ 0, df), scale = 1, direction="forward", scope = formula(lm(y~.-1, df)), steps = maxsteps), file = "/dev/null") 59 | fit <- groupfs(fd$x, df$y, fd$index, maxsteps = 10, sigma = 1, intercept = F, center = F, normalize = F, aicstop = 1) 60 | mismatches <- check.mismatch(fsfit, fit) 61 | kmismatchcount <- kmismatchcount + mismatches$count 62 | kaicdiffs[iter] <- mismatches$aicdiff 63 | } 64 | print(paste("Mismatches:", umismatchcount, "for unknown sigma and", kmismatchcount, "for known")) 65 | summary(uaicdiffs) 66 | summary(kaicdiffs) 67 | -------------------------------------------------------------------------------- /tests/test.ci.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | #library(selectiveInference,lib.loc="mylib") 3 | 4 | # 5 | ##check coverage 6 | set.seed(3) 7 | 8 | n=50 9 | p=10 10 | sigma=2 11 | 12 | x=matrix(rnorm(n*p),n,p) 13 | #x=scale(x,T,T)/sqrt(n-1) #try with and without standardization 14 | 15 | beta=c(5,4,3,2,1,rep(0,p-5)) 16 | 17 | nsim=100 18 | seeds=sample(1:9999,size=nsim) 19 | pv=rep(NA,nsim) 20 | ci=matrix(NA,nsim,2) 21 | btrue=rep(NA,nsim) 22 | lambda=20 23 | 24 | for(ii in 1:nsim){ 25 | cat(ii) 26 | set.seed(seeds[ii]) 27 | mu=x%*%beta 28 | y=mu+sigma*rnorm(n) 29 | y=y-mean(y) 30 | gfit=glmnet(x,y,standardize=F,lambda.min.ratio=1e-9) 31 | # ilam=trunc(length(gfit$lam)/4) 32 | # lambda=gfit$lam[ilam]*n 33 | bhat = predict(gfit, s=lambda/n,type="coef",exact=TRUE)[-1] 34 | 35 | junk= fixedLassoInf(x,y,bhat,lambda,sigma=sigma) 36 | pv[ii]=junk$pv[1] 37 | ## oo=junk$pred # for old package 38 | oo=junk$var # for new package 39 | btrue[ii]=lsfit(x[,oo],mu,intercept=F)$coef[1] 40 | ci[ii,]=junk$ci[1,] 41 | } 42 | 43 | mean(ci[,1]> btrue) 44 | mean(ci[,2]< btrue) 45 | -------------------------------------------------------------------------------- /tests/test.cv.R: -------------------------------------------------------------------------------- 1 | 2 | library(MASS) 3 | library(intervals) 4 | source("../josh/quadratic.R") 5 | source("../josh/cv.R") 6 | source("../josh/groupfs.R") 7 | 8 | set.seed(1) 9 | niters <- 500 10 | n <- 40 11 | p <- 20 12 | steps <- 10 13 | sparsity <- 5 14 | snr <- 2 15 | nfolds <- 5 16 | 17 | instance <- function(n, p, sparsity, snr, steps, nfolds) { 18 | 19 | x <- matrix(rnorm(n*p), nrow=n) 20 | y <- rnorm(n) 21 | 22 | if (sparsity > 0) { 23 | beta <- rep(0, p) 24 | beta[1:sparsity] <- snr * sample(c(-1,1), sparsity, replace=T) 25 | y <- y + x %*% beta 26 | } 27 | 28 | fit <- cv_fs(x, y, steps=steps, nfolds=nfolds) 29 | x <- x[fit$cvperm, ] 30 | y <- y[fit$cvperm] 31 | 32 | pvals_naive <- interval.groupfs(fit, x, y, index = 1:ncol(x)) 33 | 34 | fit$projections <- c(fit$projections, fit$rssprojections) 35 | pvals_reduced <- interval.groupfs(fit, x, y, index = 1:ncol(x)) 36 | 37 | fit$projections <- c(fit$projections, fit$foldprojections) 38 | pvals <- interval.groupfs(fit, x, y, index = 1:ncol(x)) 39 | 40 | return(list(variable = fit$variable, pvals = pvals, 41 | pvals_naive = pvals_naive, pvals_reduced = pvals_reduced)) 42 | } 43 | 44 | time <- system.time({ 45 | output <- replicate(niters, instance(n, p, sparsity, snr, steps, nfolds)) 46 | }) 47 | 48 | pvals_reduced <- do.call(c, list(output[4,])) 49 | pvals_naive <- do.call(c, list(output[3,])) 50 | pvals <- do.call(c, list(output[2,])) 51 | vars <- do.call(c, list(output[1,])) 52 | 53 | save(pvals, pvals_reduced, pvals_naive, vars, file = paste0( 54 | "results_cv_n", n, 55 | "_p", p, 56 | "_sparsity", sparsity, 57 | "_snr", snr, 58 | ".RData")) 59 | 60 | print(time) 61 | -------------------------------------------------------------------------------- /tests/test.fs.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | 3 | options(error=dump.frames) 4 | 5 | 6 | library(lars) 7 | 8 | set.seed(0) 9 | n = 100 10 | p = 100 11 | s = 3 12 | size = 5 13 | 14 | sigma = 1 15 | x = matrix(rnorm(n*p),n,p) 16 | #x = scale(x,T,F)/sqrt(n-1) 17 | 18 | b = c(sample(c(-1,1),s,replace=T)*rep(size,s),rep(0,p-s)) 19 | mu = x%*%b 20 | y = mu + sigma*rnorm(n) 21 | 22 | obj = fs(x,y,verb=T,intercept=T,norm=T) 23 | obj2 = lars(x,y,type="step",intercept=T,norm=T) 24 | 25 | max(abs(obj$action-unlist(obj2$action))) 26 | # These don't always match ... what is the lars function doing? 27 | 28 | # Checks 29 | max(abs(obj$action-unlist(obj2$action))) 30 | max(abs(coef(obj,s=4.5,mode="step")- 31 | lars::predict.lars(obj2,s=4.5,type="coef",mode="step")$coef)) 32 | max(abs(predict(obj,s=4.5,mode="step")- 33 | lars::predict.lars(obj2,s=4.5,newx=x,mode="step")$fit)) 34 | 35 | # Sequential inference 36 | out = fsInf(obj,sigma=sigma,k=20) 37 | out 38 | sum(out$ci[,1]>out$ci[,2]) 39 | plot(out$pv,ylim=c(0,1)) 40 | 41 | # AIC inference 42 | k = 20 43 | out2 = fsInf(obj,sigma=sigma,k=k,type="aic") 44 | out2 45 | 46 | # Fixed step inference 47 | k = out2$khat 48 | out3 = fsInf(obj,sigma=sigma,k=k,type="all") 49 | out3 50 | 51 | # Least squares inference 52 | X = x[,obj$action[1:k]] 53 | out.ls = lm(y~X+0) 54 | summary(out.ls) 55 | 56 | # Don't lose much, in terms of conditioning on AIC event, 57 | # The p-values look good here! 58 | 59 | ################# 60 | ################# 61 | # Another random seed 62 | 63 | set.seed(1) 64 | n = 25 65 | p = 50 66 | s = 3 67 | size = 10 68 | 69 | sigma = 1 70 | x = matrix(rnorm(n*p),n,p) 71 | b = c(sample(c(-1,1),s,replace=T)*rep(size,s),rep(0,p-s)) 72 | mu = x%*%b 73 | y = mu + sigma*rnorm(n) 74 | 75 | obj = lar(x,y,verb=T,intercept=T,norm=T) 76 | 77 | # Sequential inference 78 | out = larInf(obj,sigma=sigma) 79 | out 80 | 81 | # AIC inference 82 | k = 15 83 | out2 = larInf(obj,sigma=sigma,k=k,type="aic") 84 | out2 85 | 86 | # Fixed step inference 87 | k = out2$khat 88 | out3 = larInf(obj,sigma=sigma,k=k,type="all") 89 | out3 90 | 91 | # Least squares inference 92 | out.ls = lm(y~x[,obj$action[1:k]]) 93 | summary(out.ls) 94 | 95 | # Explore fixed step inferences 96 | larInf(obj,sigma=sigma,k=3,type="all") 97 | larInf(obj,sigma=sigma,k=4,type="all") 98 | larInf(obj,sigma=sigma,k=5,type="all") 99 | larInf(obj,sigma=sigma,k=6,type="all") 100 | larInf(obj,sigma=sigma,k=7,type="all") 101 | larInf(obj,sigma=sigma,k=8,type="all") 102 | larInf(obj,sigma=sigma,k=9,type="all") 103 | larInf(obj,sigma=sigma,k=10,type="all") 104 | 105 | 106 | 107 | #check coverage 108 | set.seed(32) 109 | 110 | n=50 111 | p=10 112 | sigma=2 113 | 114 | x=matrix(rnorm(n*p),n,p) 115 | #x=scale(x,T,T)/sqrt(n-1) #try with and without standardization 116 | 117 | beta=c(5,4,3,2,1,rep(0,p-5)) 118 | beta=rep(0,p) 119 | nsim=500 120 | seeds=sample(1:9999,size=nsim) 121 | pv=rep(NA,nsim) 122 | ci=matrix(NA,nsim,2) 123 | btrue=rep(NA,nsim) 124 | mu=x%*%beta 125 | for(ii in 1:nsim){ 126 | cat(ii) 127 | set.seed(seeds[ii]) 128 | 129 | y=mu+sigma*rnorm(n) 130 | y=y-mean(y) 131 | fsfit=fs(x,y,norm=T) 132 | 133 | junk= fsInf(fsfit,sigma=sigma) 134 | pv[ii]=junk$pv[1] 135 | oo=junk$var[1] 136 | btrue[ii]=lsfit(x[,oo],mu)$coef[2] 137 | ci[ii,]=junk$ci[1,] 138 | } 139 | plot((1:nsim)/nsim,sort(pv)) 140 | abline(0,1) 141 | 142 | 143 | sum(ci[,1]> btrue) 144 | sum(ci[,2]< btrue) 145 | 146 | 147 | 148 | ##diabetes example 149 | x=read.table("/Users/tibs/dropbox/PAPERS/FourOfUs/data64.txt") 150 | x=as.matrix(x) 151 | x=scale(x,T,F) 152 | #x=scale(x,T,T) 153 | n=length(y) 154 | 155 | nams=scan("/Users/tibs/dropbox/PAPERS/FourOfUs/data64.names",what="") 156 | y=scan("/Users/tibs/dropbox/PAPERS/FourOfUs/diab.y") 157 | y=y-mean(y) 158 | 159 | obj = fs(x,y,verb=T,intercept=T,norm=T) 160 | 161 | # Sequential inference 162 | 163 | sigma= estimateSigma(x,y)$sigmahat 164 | out = fsInf(obj,sigma=sigma,k=20) 165 | out 166 | 167 | 168 | # AIC inference 169 | 170 | out2 = fsInf(obj,sigma=sigma,type="aic") 171 | out2 172 | 173 | # Fixed step inference 174 | k = out2$khat 175 | out3 = fsInf(obj,sigma=sigma,k=k,type="all") 176 | out3 177 | out4 = fsInf(obj,sigma=sigma,k=k,type="all",bits=200) 178 | 179 | ##plot 180 | 181 | library(selectiveInference) 182 | 183 | options(error=dump.frames) 184 | 185 | 186 | set.seed(33) 187 | n = 50 188 | p = 10 189 | sigma = 1 190 | x = matrix(rnorm(n*p),n,p) 191 | beta = c(3,2,rep(0,p-2)) 192 | y = x%*%beta + sigma*rnorm(n) 193 | 194 | # run forward stepwise, plot results 195 | fsfit = fs(x,y) 196 | plot(fsfit) 197 | -------------------------------------------------------------------------------- /tests/test.fs.selected.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | library(lars) 3 | 4 | set.seed(32) 5 | 6 | n=50 7 | p=10 8 | sigma=1 9 | 10 | x = as.matrix(read.table("X.csv", sep=',', header=FALSE)) 11 | Y = as.numeric(read.table("Y.csv", sep=',', header=FALSE)[,1]) 12 | 13 | beta=c(5,4,3,2,1,rep(0,p-5)) 14 | mu=x%*%beta 15 | 16 | y=mu+Y 17 | fsfit=fs(x,y,norm=TRUE, intercept=TRUE) 18 | out = fsInf_maxZ(fsfit,sigma=sigma) 19 | 20 | 21 | -------------------------------------------------------------------------------- /tests/test.fs_maxZ.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | options(error=dump.frames) 3 | 4 | set.seed(0) 5 | n = 20 6 | p = 5 7 | s = 3 8 | size = 5 9 | 10 | sigma = 1.5 11 | x = matrix(rnorm(n*p),n,p) 12 | 13 | 14 | b = c(sample(c(-1,1),s,replace=T)*rep(size,s),rep(0,p-s)) 15 | b=rep(0,p) 16 | mu = x%*%b 17 | nsim=200 18 | pv=matrix(NA,nsim,p) 19 | for(ii in 1:nsim){ 20 | cat(ii) 21 | y = mu + sigma*rnorm(n) 22 | 23 | obj = fs(x,y,verb=T,intercept=T,norm=T, maxsteps=p) 24 | 25 | 26 | # Sequential inference 27 | out = fsInf_maxZ(obj,sigma=sigma, ndraw=5000, burnin=1000) 28 | pv[ii,]=out$pv 29 | } 30 | 31 | 32 | par(mfrow=c(3,3)) 33 | for(j in 1:p){ 34 | plot((1:nsim)/nsim,sort(pv[,j])) 35 | abline(0,1) 36 | } 37 | -------------------------------------------------------------------------------- /tests/test.groupfs.R: -------------------------------------------------------------------------------- 1 | #library(selectiveInference) 2 | #library(lars) 3 | library(intervals) 4 | source("../selectiveInference/R/funs.groupfs.R") 5 | source("../selectiveInference/R/funs.quadratic.R") 6 | source("../selectiveInference/R/funs.common.R") 7 | 8 | set.seed(1) 9 | n <- 40 10 | p <- 80 11 | index <- sort(rep(1:(p/2), 2)) 12 | maxsteps <- 8 13 | sparsity <- 4 14 | snr <- 2 15 | 16 | system.time({ 17 | for (iter in 1:100) { 18 | y <- rnorm(n) 19 | x <- matrix(rnorm(n*p), nrow=n) 20 | beta <- rep(0, p) 21 | beta[which(index %in% 1:sparsity)] <- snr 22 | y <- y + x %*% beta 23 | fit <- groupfs(x, y, index, maxsteps = maxsteps) 24 | pvals <- groupfsInf(fit, verbose = T) 25 | } 26 | }) 27 | 28 | # Compare to step function in R 29 | index <- 1:ncol(x) 30 | y <- rnorm(n) 31 | beta <- rep(0, p) 32 | beta[which(index %in% 1:sparsity)] <- snr 33 | y <- y + x %*% beta 34 | df <- data.frame(y = y, x = x) 35 | fsfit <- step(lm(y ~ 1, df), direction="forward", scope = formula(lm(y~., df)), steps = maxsteps) 36 | fit <- groupfs(x, y, index, maxsteps) 37 | 38 | names(fsfit$coefficients)[-1] 39 | paste0("x.", fit$action) 40 | 41 | # They all match 42 | 43 | n <- nrow(state.x77) 44 | ndiv <- length(levels(state.division)) 45 | gsizes <- c(6,8,3,4,2,5,3,4, ndiv) 46 | cnames <- c(colnames(state.x77), "state.division") 47 | cnames <- gsub(" ", ".", cnames) 48 | index <- rep(1:(ncol(state.x77)+1), gsizes) 49 | labels <- unique(index) 50 | maxsteps <- max(labels)-1 51 | sparsity <- 3 52 | snr <- 5 53 | states <- data.frame(matrix(NA, nrow=n, ncol=ncol(state.x77))) 54 | colnames(states) <- colnames(state.x77) 55 | for (j in 1:ncol(state.x77)) { 56 | var <- state.x77[,j] 57 | qs <- quantile(var, probs = seq(0, 1, length.out = gsizes[j]+1)) 58 | qs <- qs[-length(qs)] 59 | for (i in 1:n) { 60 | var[i] <- sum(var[i] >= qs) 61 | } 62 | var <- as.factor(var) 63 | states[,j] <- var 64 | } 65 | states <- cbind(states, state.division) 66 | x <- factorDesign(states)$x 67 | X <- scaleGroups(x, index)$x 68 | 69 | p <- ncol(x) 70 | y <- rnorm(n) 71 | beta <- rep(0, p) 72 | nz <- sample(labels,sparsity) 73 | nzinds <- which(index %in% nz) 74 | beta[nzinds] <- snr 75 | y <- y + x %*% beta 76 | y <- y-mean(y) 77 | df <- data.frame(y = y, states) 78 | fsfit <- step(lm(y ~ 0, df), direction="forward", scope = formula(lm(y~., df)), steps = maxsteps, k = 2) 79 | fit <- groupfs(x, y, index, maxsteps, k = 2, intercept = F, center = F, normalize = T) 80 | # names(fsfit$coefficients)[-1] 81 | if (length(fsfit$coefficients) > 0) { 82 | fsnames <- cnames[which(!is.na(charmatch(cnames,names(fsfit$coefficients)[-1])))][order(unlist(lapply(cnames, function(cn) { 83 | matches = grep(cn, names(fsfit$coefficients)[-1]) 84 | if (length(matches) > 0) min(matches) 85 | else NULL 86 | })))] 87 | fsnames 88 | cnames[fit$action]#[1:length(fsnames)] 89 | } else { 90 | print("empty") 91 | } 92 | 93 | n = 100 94 | p = 120 95 | maxsteps = 9 96 | niter = 500 97 | # 10 groups of size 10, 10 groups of size 2 98 | index = sort(c(c(1, 1), rep(2:11, 10), rep(12:20, 2))) 99 | pvalm = pvalmk = matrix(NA, nrow=niter, ncol=maxsteps) 100 | 101 | for (iter in 1:niter) { 102 | x = matrix(rnorm(n*p), nrow=n) 103 | y = rnorm(n) 104 | fit = groupfs(x, y, index, maxsteps) 105 | pvals = groupfsInf(fit) 106 | pvalm[iter, ] = pvals$pv 107 | fitk = groupfs(x, y, index, maxsteps, sigma = 1) 108 | pvalsk = groupfsInf(fitk) 109 | pvalmk[iter, ] = pvalsk$pv 110 | cat(paste("Iteration", iter, "\n")) 111 | } 112 | 113 | library(ggplot2) 114 | library(reshape2) 115 | df <- melt(pvalm)[,2:3] 116 | colnames(df) <- c("step", "Pvalue") 117 | df$step <- as.factor(df$step) 118 | p <- ggplot(df, aes(Pvalue, colour = step, linetype = step)) + stat_ecdf() 119 | ggsave(filename = "test_unknown.pdf", plot = p) 120 | df <- melt(pvalmk)[,2:3] 121 | colnames(df) <- c("step", "Pvalue") 122 | df$step <- as.factor(df$step) 123 | p <- ggplot(df, aes(Pvalue, colour = step, linetype = step)) + stat_ecdf() 124 | ggsave(filename = "test_known.pdf", plot = p) 125 | 126 | print(colMeans(pvalm)) 127 | print(colMeans(pvalmk)) 128 | 129 | print(mean(pvalm)) 130 | print(mean(pvalmk)) 131 | 132 | -------------------------------------------------------------------------------- /tests/test.groupfs.rob.R: -------------------------------------------------------------------------------- 1 | #library(lars) 2 | #library(intervals) 3 | #source("../selectiveInference/R/funs.common.R") 4 | #source("../selectiveInference/R/funs.groupfs.R") 5 | source("../selectiveInference/R/funs.quadratic.R") 6 | ##source("../selectiveInference/R/funs.fs.R") 7 | #source("../selectiveInference/R/funs.lar.R") 8 | 9 | library(selectiveInference,lib.loc="/Users/tibs/dropbox/git/R/mylib") 10 | 11 | 12 | 13 | myfs=function(x,y,nsteps=min(nrow(x),ncol(x)),mode=c("ip","cor")){ 14 | p=ncol(x) 15 | # fs by minimizing scaled ip 16 | # first center x and y 17 | x=scale(x,T,F) 18 | y=y-mean(y) 19 | pred=s=scor=bhat=rep(NA,nsteps) 20 | if(mode=="ip") ip=t(x)%*%y/sqrt(diag(t(x)%*%x)) 21 | if(mode=="cor") ip=abs(cor(x,y)) 22 | pred[1]=which.max(abs(ip)) 23 | s[1]=sign(sum(x[,pred[1]]*y)) 24 | scor[1]=ip[pred[1]] 25 | bhat[1]=ip[pred[1]]/sqrt(sum(x[,pred[1]]^2)) 26 | 27 | r=lsfit(x[,pred[1]],y)$res 28 | for(j in 2:nsteps){ 29 | mod=pred[1:(j-1)] 30 | r= lsfit(x[,mod],r)$res 31 | xr= lsfit(x[,mod],x)$res 32 | if(mode=="ip") ip=t(xr)%*%r/sqrt(diag(t(xr)%*%xr)) 33 | if(mode=="cor") ip=abs(cor(xr,r)) 34 | ip[mod]=0 35 | pred[j]=which.max(abs(ip)) 36 | scor[j]=ip[pred[j]] 37 | s[j]=sign(sum(xr[,pred[j]]*r)) 38 | bhat[j]=ip[pred[j]]/sqrt(sum(xr[,pred[j]]^2)) 39 | } 40 | return(list(pred=pred,s=s,scor=scor,bhat=bhat)) 41 | } 42 | 43 | 44 | set.seed(1) 45 | n <- 40 46 | p <- 80 47 | index <- sort(rep(1:(p/2), 2)) 48 | steps <- 10 49 | sparsity <- 5 50 | snr <- 3 51 | 52 | 53 | y <- rnorm(n) 54 | x <- matrix(rnorm(n*p), nrow=n) 55 | 56 | 57 | beta <- rep(0, p) 58 | beta[which(index %in% 1:sparsity)] <- snr 59 | y <- y + x %*% beta 60 | 61 | 62 | fit <- groupfs(x, y, index, maxsteps = steps) 63 | pvals <- groupfsInf(fit) 64 | 65 | 66 | #test of size 1 groups 67 | # 68 | 69 | set.seed(1) 70 | n <- 40 71 | p <- 20 72 | index <- sort(rep(1:(p/2), 2)) 73 | steps <- 10 74 | sparsity <- 5 75 | snr <- 3 76 | 77 | 78 | 79 | x <- matrix(rnorm(n*p), nrow=n) 80 | 81 | 82 | beta <- rep(0, p) 83 | beta[which(index %in% 1:sparsity)] <- snr 84 | y <- x %*% beta+sgma*rnorm(n) 85 | 86 | 87 | 88 | fit <- groupfs(x, y, index=1:p, maxsteps = steps) 89 | 90 | groupfsInf(fit) 91 | 92 | xx=x 93 | xx[,1:2]=0 94 | xxx=scale_groups(xx,index) 95 | 96 | 97 | fit2=myfs(x,y) #my old fs 98 | fit3=fs(x,y,norm=FALSE) #current 99 | fit4=lars(x,y,type="step",norm=TRUE) 100 | 101 | fit2$pred 102 | fit3$act 103 | fit4$act 104 | max(abs(fit2$pred[1:38]-fit3$action[1:38])) 105 | # They differ at the last entry, but that's OK (not well-defined when p>n) 106 | 107 | max(abs(fit3$action[1:38]-unlist(fit4$action[1:38]))) 108 | # These don't always match, they make different selections at times. What 109 | # is the lars function doing, in type="step"? 110 | 111 | rbind(fit$act,fit2$pred[1:10],fit3$act[1:10]) 112 | 113 | fsInf(fit3,sigma=1) 114 | fsInf(fit3,sigma=1,bits=200) 115 | 116 | #minmodel=lm(y~1) 117 | #step(minmodel,direction="forward") #R step 118 | #fm = step(minmodel, direction='forward', scope=(~x[,1]+x[,2]+x[,3]+x[,4]+x[,5]+x[,6]+x[,7]+x[,8]+x[,9]+x[,10])) 119 | # fm$terms 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | -------------------------------------------------------------------------------- /tests/test.lar.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | #library(selectiveInference,lib.loc="/Users/tibs/dropbox/git/R/mylib") 3 | library(lars) 4 | 5 | set.seed(0) 6 | n = 100 7 | p = 50 8 | s = 3 9 | size = 3 10 | 11 | sigma = 1 12 | x = matrix(rnorm(n*p),n,p) 13 | b = c(sample(c(-1,1),s,replace=T)*rep(size,s),rep(0,p-s)) 14 | mu = x%*%b 15 | y = mu + sigma*rnorm(n) 16 | 17 | obj = lar(x,y,verb=F,intercept=T,norm=T) 18 | obj2 = lars(x,y,intercept=T,norm=T,type="lar") 19 | #plot(obj) 20 | 21 | # Checks 22 | max(abs(obj$lambda - obj$Gamma[obj$nk,] %*% obj$y)) 23 | max(abs(obj$lambda - obj2$lambda)) 24 | max(abs(coef(obj,s=(obj$lambda[4]+obj$lambda[5])/2,mode="lam")- 25 | lars::predict.lars(obj2,s=(obj$lambda[4]+obj$lambda[5])/2,type="coef",mode="lam")$coef)) 26 | max(abs(predict(obj,s=4.5,mode="step")- 27 | lars::predict.lars(obj2,s=4.5,newx=x,mode="step")$fit)) 28 | 29 | # Sequential inference 30 | out = larInf(obj,sigma=sigma,k=20,verbose=F) 31 | out 32 | sum(out$ci[,1]>out$ci[,2]) 33 | plot(out$pv,ylim=c(0,1)) 34 | 35 | # AIC inference 36 | k = 20 37 | out2 = larInf(obj,sigma=sigma,k=k,type="aic") 38 | out2 39 | 40 | # Fixed step inference 41 | k = out2$khat 42 | out3 = larInf(obj,sigma=sigma,k=k,type="all") 43 | print(out3,tail=TRUE) 44 | 45 | # Least squares inference 46 | out.ls = lm(y~x[,obj$action[1:k]]) 47 | summary(out.ls) 48 | 49 | # Don't lose much, in terms of conditioning on AIC event, 50 | # But the p-values don't look great here ... 51 | # We don't get significance for variables 1 and 2. When you 52 | # take k=5 steps, we do see significance 53 | 54 | # Fixed step inference 55 | larInf(obj,sigma=sigma,k=4,type="all") 56 | 57 | ### It seems like the presence of other variables in the model, 58 | ### under conditioning, messes with the p-values 59 | ### In other words, correlation between variables affects 60 | ### variable significance MORE with conditioning that without 61 | 62 | ################# 63 | ################# 64 | # Another random seed, a little more favorable results 65 | 66 | set.seed(1) 67 | n = 25 68 | p = 50 69 | s = 3 70 | size = 10 71 | 72 | sigma = 1 73 | x = matrix(rnorm(n*p),n,p) 74 | b = c(sample(c(-1,1),s,replace=T)*rep(size,s),rep(0,p-s)) 75 | mu = x%*%b 76 | y = mu + sigma*rnorm(n) 77 | 78 | obj = lar(x,y,verb=T,intercept=T,norm=T) 79 | 80 | # Sequential inference 81 | out = larInf(obj,sigma=sigma) 82 | out 83 | 84 | # AIC inference 85 | k = 15 86 | out2 = larInf(obj,sigma=sigma,k=k,type="aic") 87 | out2 88 | 89 | # Fixed step inference 90 | k = out2$khat 91 | out3 = larInf(obj,sigma=sigma,k=k,type="all") 92 | out3 93 | 94 | # Least squares inference 95 | out.ls = lm(y~x[,obj$action[1:k]]) 96 | summary(out.ls) 97 | 98 | # Explore fixed step inferences 99 | larInf(obj,sigma=sigma,k=3,type="all") 100 | larInf(obj,sigma=sigma,k=4,type="all") 101 | larInf(obj,sigma=sigma,k=5,type="all") 102 | larInf(obj,sigma=sigma,k=6,type="all") 103 | larInf(obj,sigma=sigma,k=7,type="all") 104 | larInf(obj,sigma=sigma,k=8,type="all") 105 | larInf(obj,sigma=sigma,k=9,type="all") 106 | larInf(obj,sigma=sigma,k=10,type="all") 107 | 108 | 109 | # check coverage 110 | set.seed(32) 111 | 112 | n=50 113 | p=10 114 | sigma=2 115 | 116 | x=matrix(rnorm(n*p),n,p) 117 | #x=scale(x,T,T)/sqrt(n-1) #try with and without standardization 118 | 119 | beta=c(5,4,3,2,1,rep(0,p-5))*3 120 | 121 | nsim=100 122 | seeds=sample(1:9999,size=nsim) 123 | pv=rep(NA,nsim) 124 | ci=matrix(NA,nsim,2) 125 | btrue=rep(NA,nsim) 126 | mu=x%*%beta 127 | for(ii in 1:nsim){ 128 | cat(ii) 129 | set.seed(seeds[ii]) 130 | 131 | y=mu+sigma*rnorm(n) 132 | y=y-mean(y) 133 | fsfit=lar(x,y,norm=F) 134 | 135 | junk= larInf(fsfit,sigma=sigma) 136 | pv[ii]=junk$pv[1] 137 | oo=junk$var[1] 138 | btrue[ii]=lsfit(x[,oo],mu)$coef[2] 139 | ci[ii,]=junk$ci[1,] 140 | } 141 | 142 | sum(ci[,1]> btrue) 143 | sum(ci[,2]< btrue) 144 | 145 | #diab 146 | x=read.table("/Users/tibs/dropbox/PAPERS/FourOfUs/data64.txt") 147 | x=as.matrix(x) 148 | x=scale(x,T,F) 149 | #x=scale(x,T,T) 150 | n=length(y) 151 | nams=scan("/Users/tibs/dropbox/PAPERS/FourOfUs/data64.names",what="") 152 | y=scan("/Users/tibs/dropbox/PAPERS/FourOfUs/diab.y") 153 | y=y-mean(y) 154 | 155 | larfit=lar(x,y,norm=F) 156 | sigma= estimateSigma(x,y)$sigmahat 157 | junk= larInf(larfit,sigma=sigma) 158 | junk2= larInf(larfit,sigma=sigma,type="all",k=5) 159 | junk3= larInf(larfit,sigma=sigma,type="aic") 160 | junk4= larInf(larfit,sigma=sigma,type="aic",bits=100) 161 | 162 | -------------------------------------------------------------------------------- /tests/test.manymeans.R: -------------------------------------------------------------------------------- 1 | #library(selectiveInference) 2 | library(selectiveInference,lib.loc="/Users/tibs/dropbox/git/R/mylib") 3 | 4 | set.seed(12345) 5 | 6 | n = 100 # sample size 7 | signal = 3 # signal size 8 | mu = c(rep(signal, floor (n/5)), rep(0, n-floor(n/5))) # 20% of elements get the signal; rest 0 9 | mu=sample(mu) 10 | y = mu + rnorm (n, 0, 1) 11 | 12 | mmObj = manyMeans(y, k=10, verbose=T) 13 | 14 | -------------------------------------------------------------------------------- /tests/test_QP.R: -------------------------------------------------------------------------------- 1 | library(selectiveInference) 2 | ### Test 3 | n = 80; p = 50 4 | 5 | 6 | X = matrix(rnorm(n * p), n, p) 7 | Y = rnorm(n) 8 | lam = 2 9 | 10 | soln1 = selectiveInference:::fit_randomized_lasso(X, Y, lam, 0, 0)$soln 11 | G = glmnet(X, Y, intercept=FALSE, standardize=FALSE) 12 | soln2 = coef(G, s=lam/n, exact=TRUE, x=X, y=Y)[-1] 13 | 14 | print(soln1) 15 | print(soln2) 16 | plot(soln1, soln2) 17 | print(summary(lm(soln1 ~ soln2))) 18 | 19 | -------------------------------------------------------------------------------- /tests/unifTest.R: -------------------------------------------------------------------------------- 1 | 2 | library(selectiveInference, lib.loc="/Users/tibs/dropbox/git/R-software/mylib") 3 | 4 | library(glmnet) 5 | 6 | set.seed(424) 7 | 8 | n=100 9 | p=30 10 | 11 | n=100 12 | p=200 13 | 14 | sigma=.4 15 | beta=c(3,2,-1,4,-2,2,rep(0,p-6)) 16 | #beta=rep(0,p) 17 | 18 | tr=beta!=0 19 | 20 | #type="full" 21 | type="partial" 22 | 23 | nsim = 1000 24 | lambda=.3 25 | nzb=0 26 | pvals <- matrix(NA, nrow=nsim, ncol=p) 27 | x = matrix(rnorm(n*p),n,p) 28 | x = scale(x,T,T)/sqrt(n-1) 29 | mu = x%*%beta 30 | 31 | for (i in 1:nsim) { 32 | cat(i,fill=T) 33 | y=mu+sigma*rnorm(n) 34 | y=y-mean(y) 35 | # first run glmnet 36 | gfit=glmnet(x,y,intercept=F,standardize=F,thresh=1e-8) 37 | 38 | #extract coef for a given lambda; Note the 1/n factor! 39 | bhat = coef(gfit, s=lambda/n, exact=TRUE,x=x,y=y)[-1] 40 | nzb=nzb+sum(bhat!=0) 41 | # compute fixed lambda p-values and selection intervals 42 | aa = fixedLassoInf(x,y,bhat,lambda,intercept=F,sigma=sigma,type=type) 43 | pvals[i, aa$vars] <- aa$pv 44 | } 45 | 46 | # summarize results 47 | 48 | if(type=="partial"){ 49 | nulls=rowSums(is.na(pvals[,tr]))==0 # for type=partial, nonnull setting 50 | np = pvals[nulls,-(1:sum(beta!=0))] 51 | } 52 | 53 | if(type=="full"){ 54 | nulls=1:nrow(pvals) # for type=full non null setting 55 | np = pvals[nulls,-(1:sum(beta!=0))] 56 | } 57 | 58 | 59 | 60 | #np=pvals #for null setting 61 | 62 | o=!is.na(np) 63 | 64 | #check uniformity 65 | 66 | plot((1:sum(o))/sum(o),sort(np[o]),xlab="Expected pvalue",ylab="Observed pvalue") 67 | abline(0,1) 68 | 69 | 70 | # estimate and plot FDR 71 | 72 | pvadj=pvadj.by=matrix(NA,nsim,p) 73 | for(ii in 1:nsim){ 74 | oo=!is.na(pvals[ii,]) 75 | pvadj[ii,oo]=p.adjust(pvals[ii,oo],method="BH") 76 | pvadj.by[ii,oo]=p.adjust(pvals[ii,oo],method="BY") 77 | 78 | } 79 | qqlist=c(.05, .1,.15,.2,.25,.3) 80 | fdr=se=fdr.by=se.by=rep(NA,length(qqlist)) 81 | jj=0 82 | for(qq in qqlist){ 83 | jj=jj+1 84 | 85 | r=v=r.by=v.by=rep(NA,nsim) 86 | for(ii in 1:nsim){ 87 | v[ii]=sum( (pvadj[ii,]