El estimador de James-Stein es un tipo de estimador que contrae el vector de medias hacia el origen tomado, con mayor contracción conforme la norma de $X\sim\mathcal{N}_p(\theta, \sigma^2 I_p)$ disminuye. $$\hat \delta_{𝐽𝑆}=\left(1−\frac{(𝑝−2)𝜎^2}{‖X‖^2}\right)X. $$
Iniciamos las simulaciones suponiendo una normal Gaussianana p-multivariante, fijando $p=20$, para ver la contracción que se produce en cada componente hacia el origen tomado.
Primero vemos el caso en el que el término multiplicativo del estimador de James-Stein es completamente positivo.
#Librerías necesarias
require(MASS)
require(ggplot2)
#función útil de la norma cuadrada de un vector
normsq=function(x){return(sum(x^2))}
set.seed(6)
#parámetros iniciales
p=20
theta=0
sd=1
X=rnorm(p, theta, sd) #vector normal de p medias
XS= X -(p-2)*(X/normsq(X)) #estimador de James-Stein
height= c(rep(1,p),rep(0,p))
pairing=c(1:p,1:p)
data <- data.frame( x=c(X,XS), height , pairing )
options(repr.plot.width=7, repr.plot.height=4)
ggplot (data , aes(x=x,y=height , group=pairing ))+
ylim(-0.3,1.3)+
geom_point()+
geom_line()+
annotate("text",x=0,y=c(-0.1,1.1),label=c("Estimador James-Stein", "Valor observado"))+
theme_bw()+
theme(axis.title.y=element_blank(),
axis.title.x= element_blank() , # eliminamos notaciones innecesarias de los ejes
axis.text.y= element_blank() ,
axis.ticks.y= element_blank())+
geom_point(aes(x=0, y=1),pch=8,size=4)+ # añadimos * para localizar el origen
geom_point(aes(x=0, y=0),pch=8,size=4)
Otra casuística se da cuando el término multiplicativo es negativo y por lo tanto, obtenemos un mal resultado:
set.seed(100)
theta=0
sd=1
X=rnorm(p, theta, sd) #vector normal de p medias
XS= X -(p-2)*(X/normsq(X)) # estimador de James-Stein
height= c(rep(1,p),rep(0,p))
pairing=c(1:p,1:p)
data <- data.frame( x=c(X,XS), height, pairing)
ggplot (data , aes(x=x,y=height, group=pairing))+
ylim(-0.3,1.3)+
geom_point()+
geom_line()+ # add the lines between the obs
annotate("text",x=0,y=c(-0.1,1.1),label=c("Estimador James-Stein", "Valor observado"))+
theme_bw()+ #set the background white
theme(text = element_text(size = 8)) +
theme( axis.title.y=element_blank() ,
axis.title.x= element_blank () , # removes unecessary axis annotations
axis.text.y= element_blank () ,
axis.ticks.y= element_blank())+
geom_point(aes(x=0, y =1),pch=8,size = 4)+ # add two stars to locate the mean
geom_point(aes(x=0, y =0),pch=8,size = 4)
A continuación, vemos el caso en que no todas las componentes del estimador JS son menores a las del EMV, pero que aún así hay una contracción significativa.
set.seed(123)
theta=1
sd=1
X=rnorm(p, theta, sd) #vector normal de p medias
XS= X -(p-2)*(X/normsq(X))
height= c(rep(1,p),rep(0,p)) # this is to put the true obs on top and the stein estimation below
pairing=c(1:p,1:p) # this allows to draw a line between corresponding observations
data <- data.frame( x=c(X,XS), height, pairing) # data frame as it is required by ggplot
ggplot (data , aes(x=x,y=height, group=pairing))+
ylim(-0.3,1.3)+
geom_point()+
geom_line()+ # add the lines between the obs
annotate("text",x=1,y=c(-0.1,1.1),label=c("Estimador James-Stein", "Valor observado"))+
theme_bw()+ #set the background white
theme(text = element_text(size = 8)) +
theme( axis.title.y=element_blank() ,
axis.title.x= element_blank () , # removes unecessary axis annotations
axis.text.y= element_blank () ,
axis.ticks.y= element_blank())+
geom_point(aes(x=1, y =1),pch=8,size = 4)+ # add two stars to locate the mean
geom_point(aes(x=1, y =0),pch=8,size = 4)
Simulamos $N=50000$ muestras de un vector aleatorio p-variante normal $X\sim \mathcal{N}_p(\theta, \sigma^2 I_p)$, con la dimensión $p\geq 3$ variable. Es de esperar que el valor observado $X$ tenga un ECM igual a $p\sigma^2$.
En el caso Gaussiano, vemos que el estimador de James-Stein cancela completamente el aumento lineal del ECM del valor observado (estimador usual) con un valor constante de $2,5$ aproximadamente, e incluso algo mejor al tomar la versión positiva del estimador.
#Cantidad de muestras
N=50000
#varianza
s2=1
#Vectores que contendrán los riesgos
ECM_X=NULL
ECM_XS=NULL
ECM_XSP=NULL
max0= function(x){return(max(0,x))} # máximo entre 0 y x
dimensions= 3:20 # rango de p
for (p in dimensions){
theta=rep(0,p)
X=mvrnorm(n=N, theta, s2*diag(p)) # N muestras de dimensión p
XS= X- (p-2)*(X/rowSums(X^2)) # Estimador Stein
XSP=sapply(1-(p-2)/rowSums(X^2),max0)*X
#Error cuadrático
X_err= colSums((t(X)-theta)^2)
XS_err= colSums((t(XS)-theta)^2)
XSP_err= colSums((t(XSP)-theta)^2)
#Error cuadrático medio
ECM_X=c(ECM_X, mean(X_err))
ECM_XS=c(ECM_XS, mean(XS_err))
ECM_XSP=c(ECM_XSP, mean(XSP_err))
}
#Graficar el ECM como función de la norma y la media
options(repr.plot.width=7, repr.plot.height=5)
plot(dimensions, ECM_X, lty=1, type="l", ylim=c(0, p+1),
main=NULL, ylab="Riesgo", xlab="Dimensión")
lines(dimensions, ECM_XS, lty=2)
lines(dimensions, ECM_XSP, lty=3)
legend("topleft", legend=c("Valor observado", "Estimador James-Stein", "Estimador James-Stein + "),lty=1:3,cex=0.7)
Si el encogimiento lo hacemos hacia el vector de medias $\theta=(1, ..., 1)$ seguimos teniendo cierta mejora aunque no tan significativa.
#Cantidad de muestras
N=50000
#varianza
s2=1
#Vectores que contendrán los riesgos
ECM_X=NULL
ECM_XS=NULL
ECM_XSP=NULL
max0= function(x){return(max(0,x))} # máximo entre 0 y x
dimensions= 3:20 # rango de p
for (p in dimensions){
theta=rep(1,p)
X=mvrnorm(n=N, theta, s2*diag(p)) # N muestras de dimensión p
XS= X- (p-2)*(X/rowSums(X^2)) # Estimador Stein
XSP=sapply(1-(p-2)/rowSums(X^2),max0)*X
#Error cuadrático
X_err= colSums((t(X)-theta)^2)
XS_err= colSums((t(XS)-theta)^2)
XSP_err= colSums((t(XSP)-theta)^2)
#Error cuadrático medio
ECM_X=c(ECM_X, mean(X_err))
ECM_XS=c(ECM_XS, mean(XS_err))
ECM_XSP=c(ECM_XSP, mean(XSP_err))
}
#Graficar el ECM como función de la norma y la media
options(repr.plot.width=7, repr.plot.height=5)
plot(dimensions, ECM_X, lty=1, type="l", ylim=c(0, p+1),
main=NULL, ylab="Riesgo", xlab="Dimensión")
lines(dimensions, ECM_XS, lty=2)
lines(dimensions, ECM_XSP, lty=3)
legend("topleft", legend=c("Valor observado", "Estimador James-Stein", "Estimador James-Stein +"),lty=1:3,cex=0.7)
Vemos también que al tomar $n\geq1$ observaciones de cada muestra, el estimador de James-Stein (JS) se obtiene a partir de $$\hat \delta_{𝐽𝑆}=\left(1−\frac{(𝑝−2)𝜎^2}{n‖\bar X‖^2}\right)\bar X. $$ Donde $\bar X$ es la matriz de medias de dimensión $N\times p$ de cada $n$.
Simulamos el caso $n=10$. El ECM esperado de $X$ será pues $\dfrac{p\sigma^2}{n}=\dfrac{p\sigma^2}{10}$. De este modo, el caso Gaussiano anterior queda graficado de la siguiente forma:
ECM_X=NULL
ECM_XS=NULL
ECM_XSP=NULL
prop=NULL
n=10
dimensions= 3:20
for (p in dimensions){
theta=rep(0,p)
X=mvrnorm(n=N, theta, (diag(p))/n) # N muestras de dimensión p con varianza igual a sigma^2/n (aquí X es \barX)
XS= X- (p-2)*(X/(n*rowSums(X^2))) # Estimador Stein
XSP=sapply(1-(p-2)/(n*rowSums(X^2)),max0)*X
#Error cuadrático
X_err= colSums((t(X)-theta)^2)
XS_err= colSums((t(XS)-theta)^2)
XSP_err= colSums((t(XSP)-theta)^2)
#Error cuadrático medio
ECM_X=c(ECM_X, mean(X_err))
ECM_XS=c(ECM_XS, mean(XS_err))
ECM_XSP=c(ECM_XSP, mean(XSP_err))
}
#Graficar el ECM como función de la norma y la media
options(repr.plot.width=7, repr.plot.height=5)
plot(dimensions, ECM_X, lty=1, type="l", ylim=c(0, p+1),
main=NULL, ylab="Riesgo", xlab="Dimensión")
lines(dimensions, ECM_XS, lty=2)
lines(dimensions, ECM_XSP, lty=3)
legend("topleft", legend=c("Valor observado", "Estimador James-Stein", "Estimador James-Stein +"), lty=1:3,cex=0.7)
Es decir, los estimadores JS y JS+ siguen cancelando el aumento del ECM de $X$ pero esta vez con un valor constante muy cercano a $0$. Esto muestra que cuanta más información no dispar tenemos, menor es el riesgo.
Cabe remarcar que, el estimador JS centrado (y derivados) no deja de ser el estimador empírico Bayesiano de James-Stein, es cual calculamos de la siguiente manera: $$\hat \delta_{𝐽𝑆}=\bar X + \left(1−\frac{(𝑝−3)\sigma^2}{n‖X -\bar X‖^2}\right)(X - \bar X). $$
Tomando ahora $p\geq4$.
Suponemos entonces, que nuestro vector de medias sigue una distribución previa, $\theta\sim (\mu, \tau^2)$ con $\mu=0$ y $\tau$=1. Y vemos el caso $n=10$.
require(MASS)
require(ggplot2)
set.seed(24367)
max0= function(x){return(max(0,x))} # máximo entre 0 y x
#Dimensiones
N=50000
n=10
dimensions= 4:20
#Vectores de los riesgos
ECM_X=NULL
ECM_XS=NULL
ECM_XSP=NULL
ECM_XSC=NULL
ECM_XSCP=NULL
tau=1
sigma=1
for(p in dimensions){
mu= rep(0,p)
Tau<-diag(rep(tau^2,p))
theta= mvrnorm(1,mu,Tau) #vector de medias con distribución previa
M= matrix(rep(theta,each=N),nrow=N) #matriz con cada fila el vector de medias theta
X=array(0,dim=c(N,p,n))
for (i in 1:p){
X[,i,]<-rnorm(n*N,mean=theta[i],sigma)
}
Xm=apply(X,c(1,2),mean) #matriz de medias empíricas
#Estimadores JS y JS+
JS=matrix(1-(p-2)*(sigma^2)/(n*(rowSums(Xm^2))),nrow=N,ncol=p)*Xm
JSP=matrix(sapply(1-(p-2)*(sigma^2)/(n*(rowSums(Xm^2))), max0),nrow=N,ncol=p)*Xm
#Estimadores JS centrado y centrado+
X_cent= Xm-rowMeans(Xm) # Centrado
XS_cent= X_cent-(p-3)*(X_cent/(n*rowSums(X_cent^2))) # Estimador Stein centrado
XS_cent2= sapply(1-(p-3)/(n*rowSums(X_cent^2)),max0)*X_cent # Estimador Stein centrado +
# "descentrando"
JSC= XS_cent + rowMeans(Xm)
JSCP= XS_cent2 + rowMeans(Xm)
#Error cuadrático
Err_X=rowSums((Xm-M)^2)
Err_XS=rowSums((JS-M)^2)
Err_XSP=rowSums((JSP-M)^2)
Err_XSC=rowSums((JSC-M)^2)
Err_XSCP=rowSums((JSC-M)^2)
#Error cuadrático medio
ECM_X=c(ECM_X, mean(Err_X))
ECM_XS=c(ECM_XS, mean(Err_XS))
ECM_XSP=c(ECM_XSP, mean(Err_XSP))
ECM_XSC=c(ECM_XSC, mean(Err_XSC))
ECM_XSCP=c(ECM_XSCP, mean(Err_XSCP))
}
#Graficar el riesgo como función de la norma y la media
options(repr.plot.width=7, repr.plot.height=5)
plot(dimensions, ECM_X, lty=1, type="l", ylim=c(0, p+1), main=NULL, ylab="Riesgo", xlab="Dimensión")
lines(dimensions, ECM_XS, lty=2)
lines(dimensions, ECM_XSP, lty=3)
lines(dimensions, ECM_XSC, lty=4)
lines(dimensions, ECM_XSCP, lty=5)
legend("topleft", legend=c("Valor observado","Estimador James-Stein", "Estimador James-Stein +", "Estimador James-Stein centrado", "Estimador James-Stein centrado + "),
lty=1:5,cex=0.7)
Y si $n=1$, comparándolo con el caso $X\sim\mathcal(\theta,I)$ con $\theta$ Gaussiana, vemos que al añadir varianza al vector de medias, los estimadores presentan más desviación.
require(MASS)
require(ggplot2)
set.seed(24367)
max0= function(x){return(max(0,x))} # máximo entre 0 y x
#Dimensiones
N=50000
n=1
dimensions= 4:20
#Vectores de los riesgos
ECM_X=NULL
ECM_XS=NULL
ECM_XSP=NULL
ECM_XSC=NULL
ECM_XSCP=NULL
tau=1
sigma=1
for(p in dimensions){
mu= rep(0,p)
Tau<-diag(rep(tau^2,p))
theta= mvrnorm(1,mu,Tau) #vector de medias con distribución previa
M= matrix(rep(theta,each=N),nrow=N) #matriz con cada fila el vector de medias theta
X=array(0,dim=c(N,p,n))
for (i in 1:p){
X[,i,]<-rnorm(n*N,mean=theta[i],sigma)
}
Xm=apply(X,c(1,2),mean) #matriz de medias empíricas
#Estimadores JS y JS+
JS=matrix(1-(p-2)*(sigma^2)/(n*(rowSums(Xm^2))),nrow=N,ncol=p)*Xm
JSP=matrix(sapply(1-(p-2)*(sigma^2)/(n*(rowSums(Xm^2))), max0),nrow=N,ncol=p)*Xm
#Estimadores JS centrado y centrado+
X_cent= Xm-rowMeans(Xm) # Centrado
XS_cent= X_cent-(p-3)*(X_cent/(n*rowSums(X_cent^2))) # Estimador Stein centrado
XS_cent2= sapply(1-(p-3)/(n*rowSums(X_cent^2)),max0)*X_cent # Estimador Stein centrado +
# "descentrando"
JSC= XS_cent + rowMeans(Xm)
JSCP= XS_cent2 + rowMeans(Xm)
#Error cuadrático
Err_X=rowSums((Xm-M)^2)
Err_XS=rowSums((JS-M)^2)
Err_XSP=rowSums((JSP-M)^2)
Err_XSC=rowSums((JSC-M)^2)
Err_XSCP=rowSums((JSC-M)^2)
#Error cuadrático medio
ECM_X=c(ECM_X, mean(Err_X))
ECM_XS=c(ECM_XS, mean(Err_XS))
ECM_XSP=c(ECM_XSP, mean(Err_XSP))
ECM_XSC=c(ECM_XSC, mean(Err_XSC))
ECM_XSCP=c(ECM_XSCP, mean(Err_XSCP))
}
#Graficar el riesgo como función de la norma y la media
plot(dimensions, ECM_X, lty=1, type="l", ylim=c(0, p+1), main=NULL, ylab="Riesgo", xlab="Dimensión")
lines(dimensions, ECM_XS, lty=2)
lines(dimensions, ECM_XSP, lty=3)
lines(dimensions, ECM_XSC, lty=4)
lines(dimensions, ECM_XSCP, lty=5)
legend("topleft", legend=c("Valor observado","Estimador James-Stein", "Estimador James-Stein +", "Estimador James-Stein centrado", "Estimador James-Stein centrado + "),
lty=1:5,cex=0.7)
Pero si $\tau=5$ (aumentamos la varianza) entonces reducimos la mejora:
require(MASS)
require(ggplot2)
set.seed(24367)
max0= function(x){return(max(0,x))} # máximo entre 0 y x
#Dimensiones
N=50000
n=1
dimensions= 4:20
#Vectores de los riesgos
ECM_X=NULL
ECM_XS=NULL
ECM_XSP=NULL
ECM_XSC=NULL
ECM_XSCP=NULL
tau=5
sigma=1
for(p in dimensions){
mu= rep(1,p)
Tau<-diag(rep(tau^2,p))
theta= mvrnorm(1,mu,Tau) #vector de medias con distribución previa
M= matrix(rep(theta,each=N),nrow=N) #matriz con cada fila el vector de medias theta
X=array(0,dim=c(N,p,n))
for (i in 1:p){
X[,i,]<-rnorm(n*N,mean=theta[i],sigma)
}
Xm=apply(X,c(1,2),mean) #matriz de medias empíricas
#Estimadores JS y JS+
JS=matrix(1-(p-2)*(sigma^2)/(n*(rowSums(Xm^2))),nrow=N,ncol=p)*Xm
JSP=matrix(sapply(1-(p-2)*(sigma^2)/(n*(rowSums(Xm^2))), max0),nrow=N,ncol=p)*Xm
#Estimadores JS centrado y centrado+
X_cent= Xm-rowMeans(Xm) # Centrado
XS_cent= X_cent-(p-3)*(X_cent/(n*rowSums(X_cent^2))) # Estimador Stein centrado
XS_cent2= sapply(1-(p-3)/(n*rowSums(X_cent^2)),max0)*X_cent # Estimador Stein centrado +
# "descentrando"
JSC= XS_cent + rowMeans(Xm)
JSCP= XS_cent2 + rowMeans(Xm)
#Error cuadrático
Err_X=rowSums((Xm-M)^2)
Err_XS=rowSums((JS-M)^2)
Err_XSP=rowSums((JSP-M)^2)
Err_XSC=rowSums((JSC-M)^2)
Err_XSCP=rowSums((JSC-M)^2)
#Error cuadrático medio
ECM_X=c(ECM_X, mean(Err_X))
ECM_XS=c(ECM_XS, mean(Err_XS))
ECM_XSP=c(ECM_XSP, mean(Err_XSP))
ECM_XSC=c(ECM_XSC, mean(Err_XSC))
ECM_XSCP=c(ECM_XSCP, mean(Err_XSCP))
}
#Graficar el riesgo como función de la norma y la media
plot(dimensions, ECM_X, lty=1, type="l", ylim=c(0, p+1), main=NULL, ylab="Riesgo", xlab="Dimensión")
lines(dimensions, ECM_XS, lty=2)
lines(dimensions, ECM_XSP, lty=3)
lines(dimensions, ECM_XSC, lty=4)
lines(dimensions, ECM_XSCP, lty=5)
legend("topleft", legend=c("Valor observado","Estimador James-Stein", "Estimador James-Stein +", "Estimador James-Stein centrado", "Estimador James-Stein centrado + "),
lty=1:5,cex=0.7)
Es decir, cuanta mayor sea la varianza del vector de medias más se aproximan nuestros estimadores al EMV, y por lo tanto, menos mejora. Además, comparando los casos $n=10$ y $n=1$ de $X\sim \mathcal{N}(\theta, I_p)$, $\theta\sim\mathcal{N}(1, 1)$ observamos que al tener más observaciones con varianza de $\theta$ obtenemos menor mejora.
Creamos una función para graficar los ECM según los distintos tipos de estimadores: el estimador usual (valor observado), el de James-Stein, el centrado y el de la parte positiva centrado para ver las mejoras que aportan según el tipo de vector de medias que tenemos. Fijamos $Var(X)=\sigma^2=1$.
Dicha función la calculamos en base al vector de medias así como en base a las observaciones que tengamos de cada muestra, $n\geq1$.
## función que computa y grafica el ECM para distintos tipos EJS ##
#Librerías necesarias
require(MASS)
require(ggplot2)
#funciones útiles
normsq=function(x){return(sum(x^2))}
max0= function(x){return(max(0,x))}
N=50000
p=20
Stein_estimator= function(theta, range,n){
p=length(theta)
#vectores con el ECM
ECM_X=NULL
ECM_XS=NULL
ECM_XSC=NULL
ECM_XSC2=NULL
# vector que contiene la norma y la media, para graficar
Norm_theta=NULL
for (i in range){
X=mvrnorm(n=N, i*theta, (diag(p)/n)) #N muestras de dimensión p
XS= X- (p-2)*(X/(n*rowSums(X^2))) #Estimador Stein
X_cent= X-rowMeans(X) #Centramos X
XS_cent= X_cent-(p-3)*(X_cent/(n*rowSums(X_cent^2))) #Estimador Stein centrado
XS_cent2= sapply(1-(p-3)/(n*rowSums(X_cent^2)),max0)*X_cent #Estimador Stein centrado +
#"descentrando"
XSC= XS_cent + rowMeans(X)
XSC2= XS_cent2 + rowMeans(X)
#Error cuadrático
X_err= colSums((t(X)-i*theta)^2)
XS_err= colSums((t(XS)-i*theta)^2)
XSC_err= colSums((t(XSC)-i*theta)^2)
XSC2_err= colSums((t(XSC2)-i*theta)^2)
#Error cuadrático medio
ECM_X=c(ECM_X, mean(X_err))
ECM_XS=c(ECM_XS, mean(XS_err))
ECM_XSC=c(ECM_XSC, mean(XSC_err))
ECM_XSC2=c(ECM_XSC2, mean(XSC2_err))
#Norma cuadrática de theta (para las x-coordenadas del gráfico)
Norm_theta=c(Norm_theta, normsq(i*theta))
}
#Graficar el ECM como función de la norma y la media
options(repr.plot.width=7, repr.plot.height=5)
plot(Norm_theta, ECM_X, lty=1, type="l", ylim=c(0, p+1),
main=NULL, ylab="Riesgo", xlab="||theta||^2")
lines(Norm_theta, ECM_XS, lty=2)
lines(Norm_theta, ECM_XSC, lty=3)
lines(Norm_theta, ECM_XSC2, lty=4)
legend("bottomright", legend=c("Valor observado", "Estimador James-Stein", "Estimador James-Stein centrado", "Estimador James-Stein centrado + "),
lty=1:4,cex=0.7)
}
Veremos que cuanto vayor varianza del vector de medias, menor mejora tendremos (Efron, 1992). Es decir, cuando las coordenadas de $\theta$ tengan magnitud similar será cuando obtendremos mejores ganancias (menor riesgo).
Simulamos primero cuando la media tiene una distribución previa, $\theta\sim \mathcal{N}(\mu, \tau^2)$. Observamos el caso $\mu=1$ y $\tau=1$.
p=20
n=1
theta= rnorm(p,1,1)
range= sqrt(0:100/14) #multiplicador del vector de medias
Stein_estimator(theta, range,n) #con 1 observación
Si aumentamos la varianza, $\theta\sim \mathcal{N}(1, 5^2)$
p=20
n=1
theta= rnorm(p,1,5^2)
range= sqrt(0:10/1000) #multiplicador del vector de medias
Stein_estimator(theta, range,n) #con 1 observación
Con $\theta$ Gaussiana:
p=20
n=1
theta= rnorm(p,0,1)
range= sqrt(0:100/14) #multiplicador del vector de medias
Stein_estimator(theta, range,n) #con 1 observación
Ahora si $\theta\sim Pois(\lambda)$, $\lambda=1$.
p=20
n=1
theta= rpois(p,1)
range= sqrt(0:100/10) #multiplicador del vector de medias
Stein_estimator(theta, range,n) #con 1 observación
Cuando la media es cercana a un múltiplo de $\theta=(1, ..., 1)$
n=1
theta= rep(1, p) #O equivalentemente, theta= N(1,0). Hemos disminuido tau.
range= sqrt(0:100/10) #multiplicador del vector de medias
Stein_estimator(theta, range,n) #con 1 observación
Cuando la media es cercana a un múltiplo de $\theta=(1, 2, ..., p)$
n=1
theta= 1:p
range= sqrt((0:100)/1400)
Stein_estimator(theta, range,n)
Cuando la media es cercana a un múltiplo de $\theta=(-1, ...,-1, 1, ..., 1)$
n=1
p=20
theta= c(rep(-1, p/2), rep(1, p/2))
range= sqrt(0:100/10)
Stein_estimator(theta, range,n)
Cuando la media es un múltiplo de $\theta=(0, ..., 0, 1)$. Disminuímos la dimensión para que se aprecie más.
n=1
p=5
theta= rep(0, p-1)
theta=c(theta, 1)
range= sqrt(0:20)
Stein_estimator(theta, range,n)
Vayamos ahora al caso donde la matriz de covarianzas es un múltiplo desconocido de la identidad. Tendremos que aproximarla mediante una distribució ji cuadrado.
ECM_X=NULL
ECM_XS=NULL
ECM_XS2=NULL
N=50000
p=20
n=10 #en este caso n = grados de libertad
theta=rep(1, p)
variance= (1:20)/10
for(v in variance){
#estimo s siguiendo una sigma^2 chi-quadrada
s= v*rchisq(n = N, df = n)
X= mvrnorm(n=N, theta, v*diag(p)) #N muestras de dim p
XS= X-(p-2)*(s/n)*(X/rowSums(X^2)) #Estimador d'Stein c= 1/n
XS2= X-(p-2)*(s/(n+2))*(X/rowSums(X^2)) #Estimador d'Stein c= 1/(n+2)
#EC
X_err= colSums((t(X)-theta)^2)
XS_err= colSums((t(XS)-theta)^2)
XS2_err= colSums((t(XS2)-theta)^2)
#ECM
ECM_X=c(ECM_X, mean(X_err))
ECM_XS=c(ECM_XS, mean(XS_err))
ECM_XS2=c(ECM_XS2, mean(XS2_err))
}
#Graficar el ECM como función de la norma y la media
plot(variance, ECM_X, lty=1, type="l", ylim=c(0, max(ECM_X)),
main=NULL, ylab="Riesgo", xlab="Varianza")
lines(variance, ECM_XS, lty=2)
lines(variance, ECM_XS2, lty=3)
legend("topleft", legend=c("Valor observado", "Estimador James-Stein con c=1/n", "Estimador James-Stein con c=1/(n+2) "),
lty=1:3,cex=0.7)
Comparamos ahora el estimador de James-Stein entre el caso normal i el t-Student, suponiendo el vector de medias $\theta=0$.
require(mvtnorm)
p=20 # p-variante
theta= rep(0,p) # vector de medias de dimensión p
Sigma=diag(p) # matriz de covarianza = Id_p
df_range= 3:10 # grados de libertad de la t-student
#vectores con ECM
ECM_Xn=NULL
ECM_XnS=NULL
ECM_Xt=NULL
ECM_XtS=NULL
for(df in df_range){
Xn = mvrnorm(n=N, mu=theta, Sigma=Sigma)
XnS= Xn- (p-2)*(Xn/rowSums(Xn^2))
Xt = rmvt(n=N, sigma=Sigma, df=df)
XtS= Xt- (p-2)*(Xt/rowSums(Xt^2))
Xn_err =colSums(t(Xn)^2)
XnS_err=colSums(t(XnS)^2)
Xt_err =colSums(t(Xt)^2)
XtS_err=colSums(t(XtS)^2)
#Vectores con los riesgos
ECM_Xn =c(ECM_Xn, mean(Xn_err))
ECM_XnS=c(ECM_XnS, mean(XnS_err))
ECM_Xt =c(ECM_Xt, mean(Xt_err))
ECM_XtS=c(ECM_XtS, mean(XtS_err))
}
plot(df_range, ECM_Xn, lty=1, type="l", ylim=c(0,55), main=NULL, ylab="Riesgo", xlab="Grados de libertad")
lines(df_range, ECM_XnS, lty=2)
lines(df_range, ECM_Xt, lty=3)
lines(df_range, ECM_XtS, lty=4)
legend("topright", legend=c("Normal: Valor observado", "Normal: Estimador James-Stein",
"Student: Valor observado", "Student: Estimador James-Stein "), lty=1:4, cex=0.7 )
Ahora hacemos lo mismo pero en el caso en que la norma del vector de medias aumenta. Establecemos 6 grados de libertad, por ejemplo.
### Incrementa la media ###
Sigma= diag(p) #matriz de covarianzas
range= sqrt(0:50/10) #multiplicador de la media
#vectores con ECM
ECM_Xn=NULL
ECM_XnS=NULL
ECM_Xt=NULL
ECM_XtS=NULL
#vector con la norma de la media, para usar en el gráfico
Norm_theta=NULL
for(m in range){
theta= m*rep(1, p) #vector de medias
Xn= mvrnorm(n=N, mu=theta, Sigma=Sigma) # muestra multinormal de tamaño N para estimar el ECM
XnS= Xn- (p-2)*(Xn/rowSums(Xn^2))
Xt= rmvt(n=N, delta=theta, sigma=Sigma, df=6)
XtS= Xt- (p-2)*(Xt/rowSums(Xt^2))
Xn_err=colSums((t(Xn)-theta)^2)
XnS_err=colSums((t(XnS)-theta)^2)
Xt_err=colSums((t(Xt)-theta)^2)
XtS_err=colSums((t(XtS)-theta)^2)
#Vectores con los riesgos
ECM_Xn =c(ECM_Xn, mean(Xn_err))
ECM_XnS=c(ECM_XnS, mean(XnS_err))
ECM_Xt =c(ECM_Xt, mean(Xt_err))
ECM_XtS=c(ECM_XtS, mean(XtS_err))
#Norma cuadràtica de la media ( para el eje de las coordenadass del gráfico)
Norm_theta= c(Norm_theta, normsq(theta))
}
plot(Norm_theta, ECM_Xn, lty=1, type="l", ylim=c(0,30), main=NULL, ylab="Riesgo", xlab="||theta||^2")
lines(Norm_theta, ECM_XnS, lty=2)
lines(Norm_theta, ECM_Xt, lty=3)
lines(Norm_theta, ECM_XtS, lty=4)
legend("bottomright", legend=c("Normal: Valor observado", "Normal: Estimador James-Stein",
"Student: Valor observado", "Student: Estimador James-Stein "),
lty=1:4, cex=0.7 )
Veamos si también tenemos una contración por ejemplo con distribuciones de Poisson. Lo comparamos al caso Gaussiano
require(MASS)
require(ggplot2)
require(tidyverse)
set.seed(23978)
#Cantidad de muestras
N=50000
n=1
#varianza
s2=1
#Vectores que contendrán los riesgos
ECM_X=NULL
ECM_XS=NULL
ECM_XSP=NULL
max0= function(x){return(max(0,x))} # máximo entre 0 y x
dimensions= 3:20 # rango de p
for(p in dimensions){
theta=rep(1,p)
X=array(0,dim=c(N,p,n))
for (i in 1:p){
X[,i,]<-rpois(n*N,theta[i])
}
Xm=apply(X,c(1,2),mean) #N muestras de dimensión p
XS= Xm- (p-2)*(Xm/rowSums(Xm^2)) # Estimador Stein
XSP=sapply(1-(p-2)/rowSums(Xm^2),max0)*Xm
#Error cuadrático
X_err= colSums((t(Xm)-theta)^2)
XS_err= colSums((t(XS)-theta)^2)
XSP_err= colSums((t(XSP)-theta)^2)
#Error cuadrático medio
ECM_X=c(ECM_X, mean(X_err))
ECM_XS=c(ECM_XS, mean(XS_err))
ECM_XSP=c(ECM_XSP, mean(XSP_err))
}
#Graficar el ECM como función de la norma y la media
options(repr.plot.width=7, repr.plot.height=5)
plot(dimensions, ECM_X, lty=1, type="l", ylim=c(0, p+1),
main=NULL, ylab="Riesgo", xlab="Dimensión")
lines(dimensions, ECM_XS, lty=2)
lines(dimensions, ECM_XSP, lty=3)
legend("topleft", legend=c("Valor observado", "Estimador James-Stein", "Estimador James-Stein +"),lty=1:3,cex=0.7)
Vemos que el estimador de James-Stein también produce cierta mejora. Fijamos la dimensión $p$ y establecemos por ejemplo $6$ grados de libertad:
require(MASS)
require(ggplot2)
require(tidyverse)
#función útil de la norma cuadrada de un vector
normsq=function(x){return(sum(x^2))}
set.seed(6)
p=20 # p-variante
X=rchisq(p, df=6) #vector normal de p medias, con 6 grados de libertad
XS= X -(p-2)*(X/normsq(X)) #estimador de James-Stein
xm=mean(X)
height= c(rep(1,p),rep(0,p))
pairing=c(1:p,1:p)
data <- data.frame( x=c(X,XS), height , pairing )
options(repr.plot.width=7, repr.plot.height=4)
ggplot (data , aes(x=x,y=height , group=pairing ))+
ylim(-0.3,1.3)+
geom_point()+
geom_line()+
annotate("text",x=xm,y=c(-0.1,1.1),label=c("Estimador James-Stein", "Valor observado"))+
theme_bw()+
theme(axis.title.y=element_blank(),
axis.title.x= element_blank() , # eliminamos notaciones innecesarias de los ejes
axis.text.y= element_blank() ,
axis.ticks.y= element_blank())+
geom_point(aes(x=xm, y=1),pch=8,size=4)+ # añadimos * para localizar el origen
geom_point(aes(x=xm, y=0),pch=8,size=4)
Y en función de la dimensión $p$:
require(MASS)
require(ggplot2)
require(tidyverse)
set.seed(23978)
N=50000 #Cantidad de muestras
n=1 # catidad de observaciones de cada muestra
#Vectores que contendrán los riesgos
ECM_X=NULL
ECM_XS=NULL
ECM_XSP=NULL
max0= function(x){return(max(0,x))} # máximo entre 0 y x
dimension= 3:20 # rango de p
for(p in dimension){
theta=rep(0,p)
X=array(0,dim=c(N,p,n))
for (i in 1:p){
X[,i,]<-rchisq(n*N,6)
}
Xm=apply(X,c(1,2),mean) #N muestras de dimensión p
XS= Xm- (p-2)*(Xm/rowSums(Xm^2)) # Estimador Stein
XSP=sapply(1-(p-2)/rowSums(Xm^2),max0)*Xm
#Error cuadrático
X_err= colSums((t(Xm)-theta)^2)
XS_err= colSums((t(XS)-theta)^2)
XSP_err= colSums((t(XSP)-theta)^2)
#Error cuadrático medio
ECM_X=c(ECM_X, mean(X_err))
ECM_XS=c(ECM_XS, mean(XS_err))
ECM_XSP=c(ECM_XSP, mean(XSP_err))
}
#Graficar el ECM como función de la norma y la media
plot(dimension, ECM_X, lty=1, type="l", ylim=c(0, max(ECM_X)),
main=NULL, ylab="Riesgo", xlab="Dimensión")
lines(dimension, ECM_XS, lty=2)
lines(dimension, ECM_XSP, lty=3)
legend("topleft", legend=c("Valor observado", "Estimador James-Stein", "Estimador James-Stein +"),lty=1:3,cex=0.7)
Vemos también que fijando la dimensión $p$, la mejora se mantiene para distintos grados de libertad:
require(MASS)
require(ggplot2)
N=50000
p=20 # p-variante máximo
df_range= 3:p # grados de libertad de la ji cuadrado
#funciones útiles
normsq=function(x){return(sum(x^2))}
max0= function(x){return(max(0,x))}
#vectores con ECM
ECM_X=NULL
ECM_XS=NULL
for(df in df_range){
theta=rep(0,df)
X=rchisq(N, df) # N muestras
XS= X- (df-2)*(X/normsq(X)) # Estimador Stein
XSP=sapply(1-(df-2)/normsq(X),max0)*X
#Error cuadrático
X_err= sum(X^2)
XS_err= sum(XS^2)
XSP_err= sum(XSP^2)
#Error cuadrático medio
ECM_X=c(ECM_X, mean(X^2))
ECM_XS=c(ECM_XS, mean(XS^2))
}
tibble(df_range, ECM_X,ECM_XS)
| df_range | ECM_X | ECM_XS |
|---|---|---|
| 3 | 15.01430 | 15.01426 |
| 4 | 23.94604 | 23.94596 |
| 5 | 34.74411 | 34.74399 |
| 6 | 47.73123 | 47.73107 |
| 7 | 62.97517 | 62.97497 |
| 8 | 79.56124 | 79.56100 |
| 9 | 99.22183 | 99.22155 |
| 10 | 120.22967 | 120.22935 |
| 11 | 143.96940 | 143.96904 |
| 12 | 168.83647 | 168.83607 |
| 13 | 194.06167 | 194.06123 |
| 14 | 224.72152 | 224.72104 |
| 15 | 256.12854 | 256.12802 |
| 16 | 288.16372 | 288.16316 |
| 17 | 322.41974 | 322.41914 |
| 18 | 360.17041 | 360.16977 |
| 19 | 397.45547 | 397.45479 |
| 20 | 441.12663 | 441.12591 |