@@ -1,12 +1,12 @@

 Package: preprocessCore

-Version: 0.99.16

+Version: 0.99.17

 Title: A collection of pre-processing functions

 Author: Benjamin Milo Bolstad <bmb@bmbolstad.com>

 Maintainer: Benjamin Milo Bolstad <bmb@bmbolstad.com>

 Depends: methods

 Description: A library of core preprocessing routines 

 License: LGPL version 2 or newer

-Collate:  normalize.quantiles.R quantile_extensions.R init.R

+Collate:  normalize.quantiles.R quantile_extensions.R rcModel.R init.R

 LazyLoad: yes

 biocViews: Infrastructure

new file mode 100644

@@ -0,0 +1,47 @@

+

+

+

+rcModelPLM <- function(y){

+  if (!is.matrix(y))

+    stop("argument should be matrix")

+  PsiCode <- 0

+  PsiK <- 1.345

+  .Call("R_rlm_rma_default_model",y,PsiCode,PsiK,PACKAGE="preprocessCore")

+}

+

+

+

+rcModelWPLM <- function(y, w){

+  if (!is.matrix(y))

+    stop("argument should be matrix")

+  if (is.vector(w)){

+    if (length(w) != prod(dim(y))){

+      stop("weights are not correct length")

+    }

+  } else if (is.matrix(w)){

+    if (!all(dim(w) == dim(y))){

+      stop("weights should be same dimension as input matrix")

+    }

+

+  }

+  if (any(w < 0)){

+    stop("weights should be no negative")

+  }

+

+  

+    

+  PsiCode <- 0

+  PsiK <- 1.345

+  .Call("R_wrlm_rma_default_model",y,PsiCode,PsiK,as.double(w),PACKAGE="preprocessCore")

+

+}

+

+

+

+rcModelMedianPolish <- function(y){

+  if (!is.matrix(y))

+    stop("argument should be matrix")

+  PsiCode <- 0

+  PsiK <- 1.345

+  .Call("R_medianpolish_rma_default_model",y,PACKAGE="preprocessCore")

+}

new file mode 100644

@@ -0,0 +1,62 @@

+\name{rcModels}

+\alias{rcModelPLM}

+\alias{rcModelWPLM}

+\alias{rcModelMedianPolish}

+\title{Fit row-column model to a matrix}

+\description{These functions fit row-column effect models to matrices

+}

+\usage{

+rcModelPLM(y)

+rcModelWPLM(y, w)

+rcModelMedianPolish(y)

+}

+\arguments{

+  \item{y}{A matrix}

+  \item{w}{A matrix or vector of weights. These should be non-negative.}

+}

+\value{

+  A list with following items:

+  \item{Estimates}{The parameter estimates. Stored in column effect then

+    row effect order}

+  \item{Weights}{The final weights used}

+  \item{Residuals}{The residuals}

+  \item{StdErrors}{Standard error estimates. Stored in column effect

+    then row effect order}

+}

+\details{

+  These functions fit row-column models to the specified input

+  matrix. Specifically the model \deqn{y_{ij} = r_i + c_j +

+    \epsilon_{ij}}{y_ij = r_i + c_j + e_ij}

+       with \eqn{r_i} and \eqn{c_j} as row and column effects

+       respectively. Note that this functions treat the row effect as

+       the parameter to be constrained using sum to zero (for

+       \code{rcModelPLM} and \code{rcModelWPLM}) or median of zero (for

+       \code{rcModelMedianPolish}).

+

+       The \code{rcModelPLM} and \code{rcModelWPLM} functions use a

+       robust linear model procedure for fitting the model.

+

+       The function \code{rcModelMedianPolish} uses the median polish algorithm.

+}

+\seealso{

+}

+\examples{

+col.effects <- c(10,11,10.5,12,9.5)

+row.effects <- c(seq(-0.5,-0.1,by=0.1),seq(0.1,0.5,by=0.1))

+

+

+y <- outer(row.effects, col.effects,"+")

+w <- runif(50)

+

+rcModelPLM(y)

+rcModelWPLM(y, w)

+rcModelMedianPolish(y)

+

+y <- y + rnorm(50)

+

+rcModelPLM(y)

+rcModelWPLM(y, w)

+rcModelMedianPolish(y)

+}

+\author{B. M. Bolstad \email{bmb@bmbolstad.com}}

+\keyword{models}

\ No newline at end of file

@@ -4,7 +4,7 @@

  **

  ** Aim: Code which provides .Call() interfaces to the rlm code.

  **

- ** Copyright (C) 2006 Ben Bolstad

+ ** Copyright (C) 2006-2007 Ben Bolstad

  **

  ** created by: B. M. Bolstad <bmb@bmbolstad.com>

  ** 

@@ -13,7 +13,9 @@

  ** History

  ** Aug 16, 2006 Initial version

  ** Nov 1, 2006 - add SE to output of function

- **

+ ** Sep 13, 2007 - Make the value of the constrained parameters something more sensible

+ ** Sep 14, 2007 - Add medianpolish code interface (yes it is not really an rlm method, 

+ **                but it is analogous enough in the format presented here)

  **

  **

  *********************************************************************/

@@ -27,6 +29,9 @@

 #include "psi_fns.h"

+#include "medianpolish.h"

+

+

 #include "R_rlm_interfaces.h"

@@ -74,6 +79,8 @@ SEXP R_rlm_rma_default_model(SEXP Y, SEXP PsiCode, SEXP PsiK){

   int rows;

   int cols;

+

+  int i;

   PROTECT(dim1 = getAttrib(Y,R_DimSymbol));

   rows = INTEGER(dim1)[0];

@@ -111,8 +118,13 @@ SEXP R_rlm_rma_default_model(SEXP Y, SEXP PsiCode, SEXP PsiK){

+  beta[rows+cols -1] = 0.0;

+  se[rows+cols -1] = 0.0;

+  for (i = cols; i < rows + cols -1; i++)

+    beta[rows+cols -1]-=beta[i];

+

@@ -165,6 +177,8 @@ SEXP R_wrlm_rma_default_model(SEXP Y, SEXP PsiCode, SEXP PsiK, SEXP Weights){

   int rows;

   int cols;

+

+  int i;

   PROTECT(dim1 = getAttrib(Y,R_DimSymbol));

   rows = INTEGER(dim1)[0];

@@ -196,16 +210,120 @@ SEXP R_wrlm_rma_default_model(SEXP Y, SEXP PsiCode, SEXP PsiK, SEXP Weights){

   rlm_wfit_anova(Ymat, rows, cols, w, beta, residuals, weights, PsiFunc(asInteger(PsiCode)),asReal(PsiK), 20, 0);

-  

   rlm_compute_se_anova(Ymat, rows, cols, beta, residuals, weights,se, (double *)NULL, &residSE, 4, PsiFunc(asInteger(PsiCode)),asReal(PsiK));

+  beta[rows+cols -1] = 0.0;

+  se[rows+cols -1] = 0.0;

+

+  for (i = cols; i < rows + cols -1; i++)

+    beta[rows+cols -1]-=beta[i];

+

+

+

+

+

+

+

+  PROTECT(R_return_value_names= allocVector(STRSXP,4));

+  SET_VECTOR_ELT(R_return_value_names,0,mkChar("Estimates"));

+  SET_VECTOR_ELT(R_return_value_names,1,mkChar("Weights"));

+  SET_VECTOR_ELT(R_return_value_names,2,mkChar("Residuals"));

+  SET_VECTOR_ELT(R_return_value_names,3,mkChar("StdErrors"));

+  setAttrib(R_return_value, R_NamesSymbol,R_return_value_names);

+  UNPROTECT(2);

+  return R_return_value;

+

+}

+

+

+

+

+

+

+

+

+

+

+

+

+

+

+

+

+

+

+

+SEXP R_medianpolish_rma_default_model(SEXP Y){

+

+

+

+  SEXP R_return_value;

+  SEXP R_weights;

+  SEXP R_residuals;

+  SEXP R_beta;

+  SEXP R_SE;

+  SEXP R_return_value_names;

+  SEXP dim1;

+  double *beta;

+  double *residuals;

+  double *weights;

+  double *se;

+  double intercept;

+  double *Ymat;

+  int rows;

+  int cols;

+

+  int i;

+  

+  PROTECT(dim1 = getAttrib(Y,R_DimSymbol));

+  rows = INTEGER(dim1)[0];

+  cols = INTEGER(dim1)[1];

+  UNPROTECT(1);

+

+  PROTECT(R_return_value = allocVector(VECSXP,4));

+  PROTECT(R_beta = allocVector(REALSXP, rows + cols));

+  /* PROTECT(R_weights = allocMatrix(REALSXP,rows,cols));*/

+  PROTECT(R_residuals = allocMatrix(REALSXP,rows,cols));

+  /*  PROTECT(R_SE = allocVector(REALSXP,rows+cols)); */

+

+  R_weights = R_NilValue;

+  R_SE = R_NilValue;

+

+

+  SET_VECTOR_ELT(R_return_value,0,R_beta);

+  SET_VECTOR_ELT(R_return_value,1,R_weights);

+  SET_VECTOR_ELT(R_return_value,2,R_residuals);

+  SET_VECTOR_ELT(R_return_value,3,R_SE);

+

+  UNPROTECT(2);

+

+  beta = NUMERIC_POINTER(R_beta);

+  residuals = NUMERIC_POINTER(R_residuals);

+  /*  weights = NUMERIC_POINTER(R_weights);

+      se = NUMERIC_POINTER(R_SE);

+  */

+

+  Ymat = NUMERIC_POINTER(Y);

+

+  for (i=0; i < rows*cols; i++){

+    residuals[i] = Ymat[i];

+  }

+

+  memset(beta, 0, (rows+cols)*sizeof(double));

+

+  

+  

+  median_polish_fit_no_copy(residuals, rows, cols, &beta[cols], &beta[0], &intercept);

+

+  for (i=0; i < cols; i++)

+    beta[i]+=intercept;

@@ -219,4 +337,12 @@ SEXP R_wrlm_rma_default_model(SEXP Y, SEXP PsiCode, SEXP PsiK, SEXP Weights){

   UNPROTECT(2);

   return R_return_value;

+

+

+

+

+

+

+

+

 }

@@ -4,5 +4,6 @@

 SEXP R_rlm_rma_default_model(SEXP Y, SEXP PsiCode, SEXP PsiK);

 SEXP R_wrlm_rma_default_model(SEXP Y, SEXP PsiCode, SEXP PsiK, SEXP Weights);

+SEXP R_medianpolish_rma_default_model(SEXP Y);

 #endif

@@ -49,6 +49,7 @@ static const R_CallMethodDef callMethods[]  = {

   {"R_qnorm_within_blocks",(DL_FUNC)&R_qnorm_within_blocks,3},

   {"R_rlm_rma_default_model",(DL_FUNC)&R_rlm_rma_default_model,3},

   {"R_wrlm_rma_default_model", (DL_FUNC)&R_wrlm_rma_default_model,4},

+  {"R_medianpolish_rma_default_model", (DL_FUNC)&R_medianpolish_rma_default_model,1},

   {NULL, NULL, 0}

   };