Correction2Vect: Correction on two vectors

In PPLasso: Prognostic Predictive Lasso for Biomarker Selection

Correction on two vectors

Description

For the estimation of \tilde{β} in Zhu et al. (2022), this function keeps only the K1 largest values of prognostic biomarkers coefficients and the k2 largest value of the presictive biomarkers coefficients and set the others to the smallest value among the k1 (k2) largest of prognostic (predictive part).

Usage

Correction2Vect(X, Y, te=NULL, vector_prog, vector_pred, 
top_grill.=c(1:length(vector_prog)), delta=0.95, toZero=FALSE)

Arguments

X	Design matrix
Y	Response vector
te	treatment effects
vector_prog	Vector of prognostic biomarkers
vector_pred	Vector of predictive biomarkers
top_grill.	grill of the thresholding
delta	parameter δ in the thresholding
toZero	should the threshold to 0 or not

Value

This function returns the thresholded vector.

Author(s)

Wencan Zhu, Celine Levy-Leduc, Nils Ternes

Examples

x1=sample(1:10,10)
x2=sample(1:10,10)

X=t(sapply(c(1:10),FUN=function(x) rnorm(20)))
Y=rnorm(10)

Correction2Vect(X=X, Y=Y, vector_prog=x1, vector_pred=x2)

## The function is currently defined as
function(X, Y, te=NULL, vector_prog, vector_pred, 
top_grill.=c(1:length(vector_prog)), delta=0.95, toZero=FALSE){
  
    if(toZero){
      matrix_top_fix <- sapply(top_grill., top, vect=vector_prog)
      matrix_top_opt <- sapply(top_grill., top, vect=vector_pred)
    } else {
      matrix_top_fix <- sapply(top_grill., top_thresh, vect=vector_prog)
      matrix_top_opt <- sapply(top_grill., top_thresh, vect=vector_pred)
    }
    
    
    opt_top_opt <- mse_fix <- c()
    for(j in 1:length(top_grill.)){
      fix_temp <- matrix_top_fix[,j]
      mse_temp <- c()
      yhat <- X%*%c(te, fix_temp, matrix_top_opt[,1])

      mse_temp[1] <- sum((Y-yhat)^2)
      for(m in 2:length(top_grill.)){
        opt_temp <- matrix_top_opt[,m]
        threshed_vect <- c(te, fix_temp, opt_temp)
        yhat <- X%*%threshed_vect
        mse_temp[m] <- sum((Y-yhat)^2)
        ratio_mse <- round(mse_temp[m]/mse_temp[m-1], 6)
        if(ratio_mse >= delta){
          opt_top_opt[j] <- top_grill.[m]
          mse_fix[j] <- mse_temp[m]
          break
        }
      }
      if(m==length(top_grill.)){
        opt_top_opt[j] <- top_grill.[m]
        mse_fix[j] <- mse_temp[m]
      }
      if(j==1){
        ratio_final <- 0
      } else {
        ratio_final <- mse_fix[j]/mse_fix[j-1]
      }
      if(ratio_final >= delta){
        opt_fix <- j
        opt_opt <- m
        break
      }
    }
    
    if(exists("opt_fix")==FALSE){
      opt_fix <- ncol(matrix_top_fix)
      opt_opt <- ncol(matrix_top_opt)
    }
    

    return(c(matrix_top_fix[,opt_fix], matrix_top_opt[,opt_opt]))

}

PPLasso documentation built on March 7, 2023, 6:33 p.m.