~ubuntu-branches/ubuntu/wily/r-cran-formula/wily : revision 4

47

update = FALSE, drop = TRUE, ...)

48

{

49

## available parts

50

lpart <- 1:length(attr(x, "lhs"))

51

rpart <- 1:length(attr(x, "rhs"))

50

lpart <- 1L:length(attr(x, "lhs"))

51

rpart <- 1L:length(attr(x, "rhs"))

52

53

## default: keep all parts

54

lhs <- if(is.null(lhs)) lpart else lpart[lhs]

55

rhs <- if(is.null(rhs)) rpart else rpart[rhs]

56

if(any(is.na(lhs))) {

57

lhs <- as.vector(na.omit(lhs))

58

if(length(lhs) < 1) lhs <- 0

58

if(length(lhs) < 1L) lhs <- 0L

59

warning("subscript out of bounds, not all 'lhs' available")

60

}

61

if(any(is.na(rhs))) {

62

rhs <- as.vector(na.omit(rhs))

63

if(length(rhs) < 1) rhs <- 0

63

if(length(rhs) < 1L) rhs <- 0L

64

warning("subscript out of bounds, not all 'rhs' available")

65

}

66

68

collapse <- rep(as.logical(collapse), length.out = 2)

69

70

rval <- paste_formula(attr(x, "lhs")[lhs], attr(x, "rhs")[rhs],

71

lsep = ifelse(collapse[1], "+", "|"),

72

rsep = ifelse(collapse[2], "+", "|"))

71

lsep = ifelse(collapse[1L], "+", "|"),

72

rsep = ifelse(collapse[2L], "+", "|"))

73

74

## omit potentially redundant terms

75

if(all(collapse) & update) rval <- update(rval, if(length(rval) > 2) . ~ . else ~ .)

83

return(rval)

84

}

85

86

terms.Formula <- function(x, ..., lhs = NULL, rhs = NULL) {

86

terms.Formula <- function(x, ..., lhs = NULL, rhs = NULL, dot = "separate") {

87

88

## simplify a Formula to a formula that can be processed with

89

## terms/model.frame etc.

96

## convenience functions for checking extended features

97

is_lhs_extended <- function(Formula) {

98

## check for multiple parts

99

if(length(attr(Formula, "lhs")) > 1) {

99

if(length(attr(Formula, "lhs")) > 1L) {

100

return(TRUE)

101

} else {

102

## and multiple responses

103

if(length(attr(Formula, "lhs")) < 1) return(FALSE)

103

if(length(attr(Formula, "lhs")) < 1L) return(FALSE)

104

return(length(attr(terms(paste_formula(NULL,

105

attr(Formula, "lhs"), rsep = "+")), "term.labels")) > 1)

105

attr(Formula, "lhs"), rsep = "+")), "term.labels")) > 1L)

106

}

107

}

108

109

is_rhs_extended <- function(Formula) {

110

## check for muliple parts

111

length(attr(Formula, "rhs")) > 1

111

length(attr(Formula, "rhs")) > 1L

112

}

113

114

## simplify (if necessary)

115

ext_lhs <- is_lhs_extended(Form)

116

if(ext_lhs | is_rhs_extended(Form)) {

117

form <- if(ext_lhs) {

118

if(length(attr(Form, "rhs")) == 1 & identical(attr(Form, "rhs")[[1]], 0)) {

118

if(length(attr(Form, "rhs")) == 1L & identical(attr(Form, "rhs")[[1L]], 0)) {

119

paste_formula(NULL, attr(Form, "lhs"), rsep = "+")

120

} else {

121

paste_formula(NULL, c(attr(Form, "lhs"), attr(Form, "rhs")), rsep = "+")

130

return(form)

131

}

132

133

## simplify and then call traditional terms()

133

## check whether formula has a dot

134

has_dot <- function(formula) inherits(try(terms(formula), silent = TRUE), "try-error")

135

136

## simplify to standard formula

134

137

form <- simplify_to_formula(x, lhs = lhs, rhs = rhs)

138

139

## if necessary try to expand/update/simplify formula parts with dot

140

if(has_dot(form)) {

141

dot <- match.arg(dot, c("separate", "sequential"))

142

ll <- formula(x, rhs = 0L, collapse = TRUE)[[2L]]

143

rr <- attr(x, "rhs")

144

for(i in seq_along(rr)) {

145

if(dot == "sequential" && i > 1L) ll <- c_formula(ll, rr[[i - 1L]], sep = "+")

146

fi <- paste_formula(NULL, c_formula(rr[[i]], ll, sep = "-"))

147

attr(x, "rhs")[[i]] <- update(formula(terms(fi, ...)), . ~ .)[[3L]]

148

}

149

form <- simplify_to_formula(x, lhs = lhs, rhs = rhs)

150

}

151

152

## call traditional terms()

135

153

terms(form, ...)

136

154

}

137

155

138

model.frame.Formula <- function(formula, data = NULL, ..., lhs = NULL, rhs = NULL)

156

model.frame.Formula <- function(formula, data = NULL, ..., lhs = NULL, rhs = NULL, dot = "separate")

139

157

{

140

model.frame(terms(formula, lhs = lhs, rhs = rhs, data = data), data = data, ...)

158

model.frame(terms(formula, lhs = lhs, rhs = rhs, data = data, dot = dot), data = data, ...)

141

159

}

142

160

143

model.matrix.Formula <- function(object, data = environment(object), ..., lhs = NULL, rhs = 1)

161

model.matrix.Formula <- function(object, data = environment(object), ..., lhs = NULL, rhs = 1, dot = "separate")

144

162

{

145

163

form <- formula(object, lhs = lhs, rhs = rhs, collapse = c(FALSE, TRUE))

146

mt <- delete.response(terms(form, data = data))

164

mt <- delete.response(terms(form, data = data, dot = dot))

147

165

model.matrix(mt, data = data, ...)

148

166

}

149

167

156

174

NextMethod()

157

175

}

158

176

159

model.part.Formula <- function(object, data, lhs = 0, rhs = 0, drop = FALSE, terms = FALSE, ...) {

177

model.part.Formula <- function(object, data, lhs = 0, rhs = 0, drop = FALSE, terms = FALSE, dot = "separate", ...) {

160

178

161

179

## *hs = NULL: keep all parts

162

if(is.null(lhs)) lhs <- 1:length(attr(object, "lhs"))

163

if(is.null(rhs)) rhs <- 1:length(attr(object, "rhs"))

180

if(is.null(lhs)) lhs <- 1L:length(attr(object, "lhs"))

181

if(is.null(rhs)) rhs <- 1L:length(attr(object, "rhs"))

164

182

165

183

if(isTRUE(all.equal(as.numeric(lhs), rep(0, length(lhs)))) &

166

184

isTRUE(all.equal(as.numeric(rhs), rep(0, length(rhs)))))

167

185

stop("Either some 'lhs' or 'rhs' has to be selected.")

168

186

169

187

## construct auxiliary terms object

170

mt <- terms(object, lhs = lhs, rhs = rhs, data = data)

188

mt <- terms(object, lhs = lhs, rhs = rhs, dot = dot, data = data)

171

189

172

190

## subset model frame

173

ix <- attr(mt, "variables")[-1]

191

ix <- attr(mt, "variables")[-1L]

174

192

if(is.null(ix)) {

175

193

ix <- 0

176

194

} else {

202

220

## convenience function for updating components

203

221

update_components <- function(x, y) {

204

222

xf <- yf <- ~ .

205

xf[[2]] <- x

206

yf[[2]] <- y

207

update(xf, yf)[[2]]

223

xf[[2L]] <- x

224

yf[[2L]] <- y

225

update(xf, yf)[[2L]]

208

226

}

209

227

210

if(length(lhs) > 0) for(i in 1:length(lhs)) {

228

if(length(lhs) > 0L) for(i in 1L:length(lhs)) {

211

229

lhs[[i]] <- if(length(o_lhs) < i) n_lhs[[i]]

212

230

else if(length(n_lhs) < i) o_lhs[[i]]

213

231

else update_components(o_lhs[[i]], n_lhs[[i]])

214

232

}

215

233

216

if(length(rhs) > 0) for(i in 1:length(rhs)) {

234

if(length(rhs) > 0L) for(i in 1L:length(rhs)) {

217

235

rhs[[i]] <- if(length(o_rhs) < i) n_rhs[[i]]

218

236

else if(length(n_rhs) < i) o_rhs[[i]]

219

237

else update_components(o_rhs[[i]], n_rhs[[i]])

249

267

all.equal.Formula <- function(target, current, ...) {

250

268

rval <- NULL

251

269

252

if(length(target)[1] != length(current)[1]) {

270

if(length(target)[1L] != length(current)[1L]) {

253

271

rval <- c(rval, paste("Length mismatch: target, current differ in number of LHS parts: ",

254

length(target)[1], ", ", length(current)[1], sep = ""))

272

length(target)[1L], ", ", length(current)[1L], sep = ""))

255

273

} else if(!isTRUE(all.equal(attr(target, "lhs"), attr(current, "lhs")))) {

256

274

rval <- c(rval, "Formula mismatch: LHS formulas differ in contents")

257

275

}

258

276

259

if(length(target)[2] != length(current)[2]) {

277

if(length(target)[2L] != length(current)[2L]) {

260

278

rval <- c(rval, paste("Length mismatch: target, current differ in number of RHS parts: ",

261

length(target)[2], ", ", length(current)[2], sep = ""))

279

length(target)[2L], ", ", length(current)[2L], sep = ""))

262

280

} else if(!isTRUE(all.equal(attr(target, "rhs"), attr(current, "rhs")))) {

263

281

rval <- c(rval, "Formula mismatch: RHS formulas differ in contents")

264

282

}

283

301

284

302

stopifnot(inherits(f, "formula"))

285

303

286

rhs <- if(length(f) > 2) f[[3]] else f[[2]]

287

lhs <- if(length(f) > 2) f[[2]] else NULL

304

rhs <- if(length(f) > 2) f[[3L]] else f[[2L]]

305

lhs <- if(length(f) > 2) f[[2L]] else NULL

288

306

289

307

extract_parts <- function(x, sep = "|") {

290

308

if(is.null(x)) return(NULL)

291

309

292

310

rval <- list()

293

if(length(x) > 1 && x[[1]] == sep) {

294

while(length(x) > 1 && x[[1]] == sep) {

295

rval <- c(x[[3]], rval)

296

x <- x[[2]]

311

if(length(x) > 1L && x[[1L]] == sep) {

312

while(length(x) > 1L && x[[1L]] == sep) {

313

rval <- c(x[[3L]], rval)

314

x <- x[[2L]]

297

315

}

298

316

}

299

317

return(c(x, rval))

302

320

list(lhs = extract_parts(lhs), rhs = extract_parts(rhs))

303

321

}

304

322

323

## combine (parts of) formulas

324

c_formula <- function(f1, f2, sep = "~") {

325

326

stopifnot(length(sep) == 1L, nchar(sep) == 1L,

327

sep %in% c("~", "+", "-", "|", "&"))

328

329

if(sep == "~") {

330

rval <- . ~ .

331

rval[[3L]] <- f2

332

rval[[2L]] <- f1

333

} else {

334

rval <- as.formula(paste(". ~ .", sep, "."))

335

rval[[3L]][[3L]] <- f2

336

rval[[3L]][[2L]] <- f1

337

rval <- rval[[3L]]

338

}

339

340

return(rval)

341

}

342

305

343

## reassemble formulas

306

344

paste_formula <- function(lhs, rhs, lsep = "|", rsep = "|") {

307

345

308

## combine (parts of) formulas

309

c_formula <- function(f1, f2, sep = "~") {

310

311

stopifnot(length(sep) == 1, nchar(sep) == 1,

312

sep %in% c("~", "+", "|", "&"))

313

314

if(sep == "~") {

315

rval <- . ~ .

316

rval[[3]] <- f2

317

rval[[2]] <- f1

318

} else {

319

rval <- as.formula(paste(". ~ .", sep, "."))

320

rval[[3]][[3]] <- f2

321

rval[[3]][[2]] <- f1

322

rval <- rval[[3]]

323

}

324

325

return(rval)

326

}

327

328

stopifnot(all(nchar(lsep) == 1), all(lsep %in% c("+", "|", "&")))

329

stopifnot(all(nchar(rsep) == 1), all(rsep %in% c("+", "|", "&")))

330

331

if(length(lhs) > 1) lsep <- rep(lsep, length.out = length(lhs) - 1)

332

if(length(rhs) > 1) rsep <- rep(rsep, length.out = length(rhs) - 1)

346

stopifnot(all(nchar(lsep) == 1L), all(lsep %in% c("+", "|", "&")))

347

stopifnot(all(nchar(rsep) == 1L), all(rsep %in% c("+", "|", "&")))

348

349

if(length(lhs) > 1L) lsep <- rep(lsep, length.out = length(lhs) - 1L)

350

if(length(rhs) > 1L) rsep <- rep(rsep, length.out = length(rhs) - 1L)

333

351

334

352

if(is.null(lhs)) lhs <- list()

335

353

if(is.null(rhs)) rhs <- list()

337

355

if(!is.list(lhs)) lhs <- list(lhs)

338

356

if(!is.list(rhs)) rhs <- list(rhs)

339

357

340

lval <- if(length(lhs) > 0) lhs[[1]] else NULL

341

if(length(lhs) > 1) {

342

for(i in 2:length(lhs)) lval <- c_formula(lval, lhs[[i]], sep = lsep[[i-1]])

358

lval <- if(length(lhs) > 0L) lhs[[1L]] else NULL

359

if(length(lhs) > 1L) {

360

for(i in 2L:length(lhs)) lval <- c_formula(lval, lhs[[i]], sep = lsep[[i - 1L]])

343

361

}

344

rval <- if(length(rhs) > 0) rhs[[1]] else 0 ## FIXME: Is there something better?

345

if(length(rhs) > 1) {

346

for(i in 2:length(rhs)) rval <- c_formula(rval, rhs[[i]], sep = rsep[[i-1]])

362

rval <- if(length(rhs) > 0L) rhs[[1L]] else 0 ## FIXME: Is there something better?

363

if(length(rhs) > 1L) {

364

for(i in 2L:length(rhs)) rval <- c_formula(rval, rhs[[i]], sep = rsep[[i - 1L]])

347

365

}

348

366

349

367

c_formula(lval, rval, sep = "~")