Commit f703a1bc by Eric Coissac

Transfert bug to Christelle

parent ed0bbd34
......@@ -27,17 +27,21 @@ NULL
for (i in seq_len(ndots))
if (! is.null(dots[[i]])) nactualdots=nactualdots+1
print(nactualdots)
data = vector(mode="list", nvars + nactualdots)
names= character(nvars + nactualdots)
print(length(data))
for (i in seq_len(nvars)) {
data[[i]]=variables[[i]]
names[i]=varnames[i]
}
j=1
for (i in seq_len(ndots))
for (i in seq_len(ndots)) {
if (! is.null(dots[[i]])) {
if (nchar(dotnames[i]) + 3 > 256)
stop(sprintf("overlong names in '%s'",dotnames[i]))
......@@ -46,6 +50,7 @@ NULL
names[nvars + j]=buf
j=j+1
}
}
names(data)=names
......@@ -217,6 +222,7 @@ model.procmod.default = function (formula,
subset <- eval(substitute(subset), data, env)
print(extranames)
data = .modelprocmodframe(formula, rownames,
variables,varnames,
......
......@@ -171,15 +171,17 @@ pm = function (formula,data, subset, weights, na.action, method = "qr",
if (scale)
vars.norm = mapply(function(x,s) scale(x,scale = FALSE)/s, vars,std.dev)
else
vars.norm = mapply(function(x) scale(x,scale = FALSE), vars)
vars.norm = as.procmod.frame(mapply(function(x) scale(x,scale = FALSE), vars))
if (is.null(w)) {
subset.w=rep(TRUE,nvars)
}
else {
print(w)
sw = sqrt(w)
vars.norm = lapply(vars.norm, function(v) v * sw)
subset.w=sw > 0
vars.norm = as.procmod.frame(lapply(vars.norm, function(v) v * sw))
subset.w = sw > 0
vars.norm = vars.norm[subset.w,]
}
......
......@@ -22,7 +22,7 @@ NULL
.rep_matrix = function(x,length.out) {
N = nrow(x)
if ((length.out%%N != 0L))
if ((length.out %% N != 0L))
stop(sprintf("The size of the longest object (%d) is not a multiple of the size of the shortest (%d)",
nrows,N),
domain = NA)
......@@ -36,16 +36,16 @@ NULL
.procmod_coerce_value = function(x,nrows=0) {
xi <- if (is.data.frame(x))
as.matrix(x)
else if (is.matrix(x))
x
else
as.matrix(x)
as.matrix(x)
else if (is.matrix(x))
x
else
as.matrix(x)
dxi = dim(xi)
if (is.null(dxi))
dxi=c(1,1)
if (! is.matrix(xi))
stop('Value cannot be coerced to a Matrix')
dxi=dim(xi)
rownamesi = rownames(xi)
colnamesi = colnames(xi)
......@@ -57,13 +57,14 @@ NULL
N = nrow(xi)
if (nrows > 0L && N < nrows)
if (N > 0L && (nrows%%N == 0L))
if (nrows > 0L && N < nrows) {
if (N > 0L && (nrows %% N == 0L))
xi <- .rep_matrix(xi, length.out = nrows)
else stop(sprintf(ngettext(N, "replacement has %d row, data has %d",
"replacement has %d rows, data has %d"),
"replacement has %d rows, data has %d"),
N, nrows),
domain = NA)
}
return(xi)
}
......@@ -110,7 +111,7 @@ procmod.frame = function(...,
if (reorder.rows &&
! is.null(row.names) &&
! is.null(rownames(xi)))
xi=xi[row.names,]
xi=xi[row.names,,drop=FALSE]
nrows[i] <- nrow(xi)
value[[i]]=xi
......
......@@ -522,6 +522,69 @@ results can be ploted like a classical prooruste result
plot(euk.pm)
```
```{r}
W=1/rowSums(euk.pm$residuals^2)
W=W/max(W)
euk.pm.w = pm(euk ~ soil + climat + geo + hist,data=data,weights = W)
euk.pm.w
```
```{r}
plot(euk.pm.w)
```
```{r}
W=1/rowSums(euk.pm.w$residuals^2)
W=W/max(W)
euk.pm.w = pm(euk ~ soil + climat + geo + hist,data=data,weights = W)
euk.pm.w
```
```{r}
plot(euk.pm.w)
```
```{r}
W=1/rowSums(euk.pm.w$residuals^2)
W=W/max(W)
euk.pm.w = pm(euk ~ soil + climat + geo + hist,data=data,weights = W)
euk.pm.w
```
```{r}
plot(euk.pm.w)
```
```{r}
W=1/rowSums(euk.pm.w$residuals^2)
W=W/max(W)
euk.pm.w = pm(euk ~ soil + climat + geo + hist,data=data,weights = W)
euk.pm.w
```
```{r}
plot(euk.pm.w)
```
```{r}
W=1/rowSums(euk.pm.w$residuals^2)
W=W/max(W)
euk.pm.w = pm(euk ~ soil + climat + geo + hist,data=data,weights = W)
euk.pm.w
```
```{r}
plot(euk.pm.w)
```
finaly the analysis of the variance corresponding to this model
```{r}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment