~ubuntu-branches/ubuntu/raring/ess/raring-proposed : revision 23

1

require(methods)

2

3

#############################

4

## A. FCSmetadata class

5

#############################

6

## Methods include:

7

## 1. show

8

## 2. print

9

## 3. summary

10

## 4. [

11

## 5. [ <-

12

## 6. [[

13

## 7. [[ <-

14

######################################

15

## Examples:

16

## 1/28/2004: all work

17

######################################

18

19

## Contains critical metadata at top level, rest subseted.

20

setClass("FCSmetadata",

21

representation(mode="character",

22

size="numeric",

23

nparam="numeric",

24

shortnames="vector",

25

longnames="vector",

26

paramranges="vector",

27

filename="character",

28

objectname="character",

29

original="logical",

30

fcsinfo="list"), ## holds misc params from fcs file

31

prototype=list(mode="",

32

size=0,

33

nparam=0,

34

shortnames=vector(mode="character"),

35

longnames=vector(mode="character"),

36

paramranges=vector(mode="numeric"),

37

filename="None",

38

objectname="None",

39

original=TRUE,

40

fcsinfo=list()))

41

42

43

44

setMethod("show",

45

signature(object="FCSmetadata"),

46

function(object) {

47

48

if (object@original){

49

obj.size <- object@size

50

obj.npar <- object@nparam

51

orig.flag <- "original"

52

} else {

53

obj.size <- object@fcsinfo[["RFACSadd>>$TOT"]]

54

obj.npar <- object@fcsinfo[["RFACSadd>>$PAR"]]

55

orig.flag <- "non-original"

56

}

57

58

cat("FACSmetadata for",orig.flag, "FCS object:", object@objectname,

59

"from original file",object@filename,"\n",

60

"with ",obj.size,"cells and",

61

obj.npar,"parameters.\n")

62

invisible(object)

63

})

64

65

66

67

setMethod("print",

68

signature(x="FCSmetadata"),

69

function(x) {

70

show(x)## do stuff

71

})

72

73

74

setMethod("summary",

75

signature(object="FCSmetadata"),

76

function(object) {

77

##show(object)## do stuff

78

str(object)

79

})

80

81

## JYW: I put in the single brackets because the

82

## name of the slot is preserved in the output

83

84

## JYW: I also opted to put

85

86

## NOTE ABOUT THE ORIGINAL FLAG:

87

## the original flag only suggests that the

88

## data has been changed, NOT the metadata

89

## the original flag allows the user to

90

## extract and change the correct metadata

91

## (ie, the RFACSadd>> variables are changed when

92

## the original is FALSE or the original variables

93

## are themselves changes when the original flag

94

## is false.

95

96

97

## if original==FALSE

98

## must include the following parameters in the metadata:

99

## RFACSadd>>$TOT (vector of number of rows)

100

## RFACSadd>>$PAR (vector of number of columns)

101

## RFACSadd>>$PnS (vector of longnames)

102

## RFACSadd>>$PnN (vector of shortnames)

103

## RFACSadd>>$PnR (vector of ranges)

104

105

## original flag is ONLY changed when the data is changed

106

107

## if only part of the numeric index is valid, then only part

108

## of the fcsinfo list is output with warnings

109

110

setMethod("[",

111

signature(x="FCSmetadata"),

112

function(x,i,j,...,drop) {

113

## "i" can ONLY be EITHER a single character input

114

## OR a vector of numeric values

115

## returns only a single slot if i=character

116

## returns list elements in "fcsinfo" if i=numeric

117

118

if ( !is.character(i) & !is.numeric(i)){

119

## i is neither numeric nor character

120

stop("Input index is neither character nor numeric.")

121

} else {

122

if (is.character(i)){

123

## try to find it in the metadata ...

124

## JYW: I opted not to do the nested if statements

125

## because they were hard to read for me...

126

127

## are there any slotnames?

128

129

## are there any fcsinfo slotnames?

130

if (length(i)>1){

131

stop("Only single entry for indexing by character slot name allowed.")

132

}

133

134

## original flag... needs work

135

136

if ( sum(i %in% slotNames(x))==1 ){

137

## need original checks for

138

## size, nparam, longnames, shortnames

139

if (x@original==FALSE){

140

if ( !(i %in% c("size", "nparam",

141

"longnames", "shortnames",

142

"paramranges"))){

143

return(slot(x,i))

144

} else { ## depends on the false original flag

145

if (i == "size"){

146

return(x@fcsinfo[["RFACSadd>>$TOT"]])

147

}

148

if ( i == "nparam"){

149

return(x@fcsinfo[["RFACSadd>>$PAR"]])

150

}

151

if (i == "longnames"){

152

return(x@fcsinfo[["RFACSadd>>$PnS"]])

153

}

154

if (i=="shortnames"){

155

return(x@fcsinfo[["RFACSadd>>$PnN"]])

156

}

157

158

if (i=="paramranges"){

159

return(x@fcsinfo[["RFACSadd>>$PnR"]])

160

}

161

162

}

163

} else { ## x@original is TRUE

164

return(slot(x, i))

165

}

166

} else {

167

168

if ( sum(i %in% names(x@fcsinfo))==1) {

169

return(x@fcsinfo[[which(names(x@fcsinfo)==i)]])

170

} else {

171

if (sum(i %in% c("$PnS",

172

unlist(strsplit(paste("$P",

173

1:x@nparam,

174

"S", sep="", collapse=","),

175

split=","))))==length(i)){

176

pos.index <- c("$PnS",

177

unlist(strsplit(paste("$P", 1:x@nparam,

178

"S", sep="", collapse=","),

179

split=","))) %in% i

180

if (x@original==TRUE){

181

if (pos.index[1]==TRUE){

182

183

return(x@longnames)

184

185

} else {

186

return(x@longnames[(pos.index[-1])])

187

}

188

} else { ## x@original == FALSE

189

if (pos.index[1]==TRUE){

190

191

return(x@fcsinfo[["RFACSadd>>$PnS"]])

192

193

} else {

194

return(x@fcsinfo[["RFACSadd>>$PnS"]][(pos.index[-1])])

195

}

196

}

197

198

} else {

199

if (sum(i %in% c("$PnN",

200

unlist(strsplit(paste("$P",

201

1:x@nparam,

202

"N", sep="", collapse=","),

203

split=","))))==length(i)){

204

pos.index <- c("$PnN", unlist(strsplit(paste("$P", 1:x@nparam,

205

"N", sep="", collapse=","),

206

split=","))) %in% i

207

if (x@original==TRUE){

208

if (pos.index[1]==TRUE){

209

return(x@shortnames)

210

} else {

211

return(x@shortnames[(pos.index[-1])])

212

}

213

} else{ ## if (x@original==FALSE)

214

if (pos.index[1]==TRUE){

215

return(x@fcsinfo[["RFACSadd>>$PnN"]])

216

} else {

217

return(x@fcsinfo[["RFACSadd>>$PnN"]][(pos.index[-1])])

218

}

219

}

220

} else {

221

if (sum(i %in% c("$PnR",

222

unlist(strsplit(paste("$P",

223

1:x@nparam,

224

"R", sep="", collapse=","),

225

split=","))))==length(i)){

226

pos.index <- c("$PnR", unlist(strsplit(paste("$P", 1:x@nparam,

227

"R", sep="", collapse=","),

228

split=","))) %in% i

229

if (x@original==TRUE){

230

if (pos.index[1]==TRUE){

231

return(x@paramranges)

232

} else {

233

return(x@paramranges[(pos.index[-1])])

234

}

235

} else {## if (x@original==FALSE)

236

if (pos.index[1]==TRUE){

237

return(x@fcsinfo[["RFACSadd>>$PnR"]])

238

} else {

239

return(x@fcsinfo[["RFACSadd>>$PnR"]][(pos.index[-1])])

240

}

241

}

242

} else {

243

if (!(i %in% c("$MODE", "$TOT", "$PAR"))){

244

warning("The Slot Name cannot be found in the metadata.")

245

return(NULL)

246

} else {

247

if (i=="$MODE"){

248

return(x@mode)

249

}

250

if (i=="$TOT"){

251

if (x@original==TRUE){

252

return(x@size)

253

} else {

254

return(x@fcsinfo[["RFACSadd>>$TOT"]])

255

}

256

}

257

if (i=="$PAR"){

258

if (x@original==TRUE){

259

return(x@nparam)

260

} else {

261

return(x@fcsinfo[["RFACSadd>>$PAR"]])

262

}

263

}

264

}

265

266

267

}

268

}

269

}

270

}

271

}

272

} ## is.character(i)

273

274

if (is.numeric(i)){

275

## JYW: will do it the long way, without x@metadata[[i]]

276

## will only return value if all of the indices are found in the fcsinfo

277

278

index.i <- i %in% 1:length(x@fcsinfo)

279

280

if (sum(index.i==1) !=length(i)){

281

warning("Part or all of the Index cannot be found in the metadata.")

282

if (sum(index.i==1)==0){

283

return(NULL)

284

}

285

}

286

return(x@fcsinfo[i[index.i==1]])

287

}

288

}

289

290

291

})

292

293

294

## JYW: I put in the single brackets because the

295

## name of the slot is preserved in the output

296

297

setReplaceMethod("[",

298

signature(x="FCSmetadata"),

299

function(x,i,j,...,value) {

300

## "i" can ONLY be EITHER a single character input OR a vector of numeric values

301

## returns only a single slot if i=character

302

## returns list elements in "fcsinfo" if i=numeric

303

304

if ( !is.character(i) & !is.numeric(i)){

305

## i is neither numeric nor character

306

stop("Input index is neither character nor numeric.")

307

} else {

308

if (is.character(i)){

309

## try to find it in the metadata ...

310

## JYW: I opted not to do the nested if statements

311

## because they were hard to read for me...

312

313

## are there any slotnames?

314

315

## are there any fcsinfo slotnames?

316

if (length(i)>1){

317

stop("Only single entry for indexing by character slot name allowed.")

318

}

319

320

## original flag... needs work

321

322

if ( sum(i %in% slotNames(x))==1 ){

323

## need original checks for

324

## size, nparam, longnames, shortnames

325

if (x@original==FALSE){

326

if ( !(i %in% c("size", "nparam",

327

"longnames", "shortnames",

328

"paramranges"))){

329

slot(x,i) <- value

330

} else { ## depends on the false original flag

331

if (i == "size"){

332

x@fcsinfo[["RFACSadd>>$TOT"]] <- value

333

}

334

if ( i == "nparam"){

335

x@fcsinfo[["RFACSadd>>$PAR"]] <- value

336

}

337

if (i == "longnames"){

338

x@fcsinfo[["RFACSadd>>$PnS"]] <- value

339

}

340

if (i=="shortnames"){

341

x@fcsinfo[["RFACSadd>>$PnN"]] <- value

342

}

343

344

if (i=="paramranges"){

345

x@fcsinfo[["RFACSadd>>$PnR"]] <- value

346

}

347

348

}

349

} else { ## x@original is TRUE

350

slot(x, i) <- value

351

}

352

} else {

353

354

if ( sum(i %in% names(x@fcsinfo))==1) {

355

x@fcsinfo[[which(names(x@fcsinfo)==i)]] <- value

356

} else {

357

if (sum(i %in% c("$PnS",

358

unlist(strsplit(paste("$P",

359

1:x@nparam,

360

"S", sep="", collapse=","),

361

split=","))))==length(i)){

362

pos.index <- c("$PnS",

363

unlist(strsplit(paste("$P", 1:x@nparam,

364

"S", sep="", collapse=","),

365

split=","))) %in% i

366

if (x@original==TRUE){

367

if (pos.index[1]==TRUE){

368

369

x@longnames <- value

370

371

} else {

372

x@longnames[(pos.index[-1])] <- value

373

}

374

} else { ## x@original == FALSE

375

if (pos.index[1]==TRUE){

376

377

x@fcsinfo[["RFACSadd>>$PnS"]] <- value

378

379

} else {

380

x@fcsinfo[["RFACSadd>>$PnS"]][(pos.index[-1])] <- value

381

}

382

}

383

384

} else {

385

if (sum(i %in% c("$PnN",

386

unlist(strsplit(paste("$P",

387

1:x@nparam,

388

"N", sep="", collapse=","),

389

split=","))))==length(i)){

390

pos.index <- c("$PnN", unlist(strsplit(paste("$P", 1:x@nparam,

391

"N", sep="", collapse=","),

392

split=","))) %in% i

393

if (x@original==TRUE){

394

if (pos.index[1]==TRUE){

395

x@shortnames <- value

396

} else {

397

x@shortnames[(pos.index[-1])] <- value

398

}

399

} else{ ## if (x@original==FALSE)

400

if (pos.index[1]==TRUE){

401

x@fcsinfo[["RFACSadd>>$PnN"]] <- value

402

} else {

403

x@fcsinfo[["RFACSadd>>$PnN"]][(pos.index[-1])] <- value

404

}

405

}

406

} else {

407

if (sum(i %in% c("$PnR",

408

unlist(strsplit(paste("$P",

409

1:x@nparam,

410

"R", sep="", collapse=","),

411

split=","))))==length(i)){

412

pos.index <- c("$PnR", unlist(strsplit(paste("$P", 1:x@nparam,

413

"R", sep="", collapse=","),

414

split=","))) %in% i

415

if (x@original==TRUE){

416

if (pos.index[1]==TRUE){

417

x@paramranges <- value

418

} else {

419

x@paramranges[(pos.index[-1])] <- value

420

}

421

} else {## if (x@original==FALSE)

422

if (pos.index[1]==TRUE){

423

x@fcsinfo[["RFACSadd>>$PnR"]] <- value

424

} else {

425

x@fcsinfo[["RFACSadd>>$PnR"]][(pos.index[-1])] <- value

426

}

427

}

428

} else {

429

if (!(i %in% c("$MODE", "$TOT", "$PAR"))){

430

## cannot be found, so we make a new slot

431

len <- length(x@fcsinfo)

432

x@fcsinfo[[len+1]] <- value

433

## we do not have the RFACSadd>> prefix when just

434

## changing/adding on to the metadata

435

names(x@fcsinfo)[len+1] <- i ##paste("RFACSadd>>", i, sep="")

436

437

438

} else {

439

if (i=="$MODE"){

440

x@mode <- value

441

}

442

if (i=="$TOT"){

443

if (x@original==TRUE){

444

x@size <- value

445

} else {

446

x@fcsinfo[["RFACSadd>>$TOT"]] <- value

447

}

448

}

449

if (i=="$PAR"){

450

if (x@original==TRUE){

451

x@nparam <- value

452

} else {

453

x@fcsinfo[["RFACSadd>>$PAR"]] <- value

454

}

455

}

456

}

457

458

459

}

460

}

461

}

462

}

463

}

464

} ## is.character(i)

465

466

if (is.numeric(i)){

467

## JYW: will do it the long way, without x@metadata[[i]]

468

## will only return value if all of the indices are found in the fcsinfo

469

470

index.i <- i %in% 1:length(x@fcsinfo)

471

472

if (sum(index.i==1) !=length(i)){

473

warning("Part or all of the Index cannot be found in the metadata.")

474

475

}

476

x@fcsinfo[i[index.i==1]] <- value

477

}

478

}

479

480

481

x

482

})

483

484

485

## JYW: I put in the single brackets because the

486

## name of the slot is preserved in the output

487

488

## JYW: I also opted to put

489

setMethod("[[",

490

signature(x="FCSmetadata"),

491

function(x,i,j,...,drop) {

492

## "i" can ONLY be EITHER a single character input OR a vector of numeric values

493

## returns only a single slot if i=character

494

## returns list elements in "fcsinfo" if i=numeric

495

if ( !is.character(i) & !is.numeric(i)){

496

## i is neither numeric nor character

497

stop("Input index is neither character nor numeric.")

498

} else {

499

if (is.character(i)){

500

## try to find it in the metadata ...

501

## JYW: I opted not to do the nested if statements

502

## because they were hard to read for me...

503

504

## are there any slotnames?

505

506

## are there any fcsinfo slotnames?

507

if (length(i)>1){

508

stop("Only single entry for indexing by character slot name allowed.")

509

}

510

511

## original flag... needs work

512

513

if ( sum(i %in% slotNames(x))==1 ){

514

## need original checks for

515

## size, nparam, longnames, shortnames

516

if (x@original==FALSE){

517

if ( !(i %in% c("size", "nparam",

518

"longnames", "shortnames",

519

"paramranges"))){

520

return(slot(x,i))

521

} else { ## depends on the false original flag

522

if (i == "size"){

523

return(x@fcsinfo[["RFACSadd>>$TOT"]])

524

}

525

if ( i == "nparam"){

526

return(x@fcsinfo[["RFACSadd>>$PAR"]])

527

}

528

if (i == "longnames"){

529

return(x@fcsinfo[["RFACSadd>>$PnS"]])

530

}

531

if (i=="shortnames"){

532

return(x@fcsinfo[["RFACSadd>>$PnN"]])

533

}

534

535

if (i=="paramranges"){

536

return(x@fcsinfo[["RFACSadd>>$PnR"]])

537

}

538

539

}

540

} else { ## x@original is TRUE

541

return(slot(x, i))

542

}

543

} else {

544

545

if ( sum(i %in% names(x@fcsinfo))==1) {

546

return(x@fcsinfo[[which(names(x@fcsinfo)==i)]])

547

} else {

548

if (sum(i %in% c("$PnS",

549

unlist(strsplit(paste("$P",

550

1:x@nparam,

551

"S", sep="", collapse=","),

552

split=","))))==length(i)){

553

pos.index <- c("$PnS",

554

unlist(strsplit(paste("$P", 1:x@nparam,

555

"S", sep="", collapse=","),

556

split=","))) %in% i

557

if (x@original==TRUE){

558

if (pos.index[1]==TRUE){

559

560

return(x@longnames)

561

562

} else {

563

return(x@longnames[(pos.index[-1])])

564

}

565

} else { ## x@original == FALSE

566

if (pos.index[1]==TRUE){

567

568

return(x@fcsinfo[["RFACSadd>>$PnS"]])

569

570

} else {

571

return(x@fcsinfo[["RFACSadd>>$PnS"]][(pos.index[-1])])

572

}

573

}

574

575

} else {

576

if (sum(i %in% c("$PnN",

577

unlist(strsplit(paste("$P",

578

1:x@nparam,

579

"N", sep="", collapse=","),

580

split=","))))==length(i)){

581

pos.index <- c("$PnN", unlist(strsplit(paste("$P", 1:x@nparam,

582

"N", sep="", collapse=","),

583

split=","))) %in% i

584

if (x@original==TRUE){

585

if (pos.index[1]==TRUE){

586

return(x@shortnames)

587

} else {

588

return(x@shortnames[(pos.index[-1])])

589

}

590

} else{ ## if (x@original==FALSE)

591

if (pos.index[1]==TRUE){

592

return(x@fcsinfo[["RFACSadd>>$PnN"]])

593

} else {

594

return(x@fcsinfo[["RFACSadd>>$PnN"]][(pos.index[-1])])

595

}

596

}

597

} else {

598

if (sum(i %in% c("$PnR",

599

unlist(strsplit(paste("$P",

600

1:x@nparam,

601

"R", sep="", collapse=","),

602

split=","))))==length(i)){

603

pos.index <- c("$PnR", unlist(strsplit(paste("$P", 1:x@nparam,

604

"R", sep="", collapse=","),

605

split=","))) %in% i

606

if (x@original==TRUE){

607

if (pos.index[1]==TRUE){

608

return(x@paramranges)

609

} else {

610

return(x@paramranges[(pos.index[-1])])

611

}

612

} else {## if (x@original==FALSE)

613

if (pos.index[1]==TRUE){

614

return(x@fcsinfo[["RFACSadd>>$PnR"]])

615

} else {

616

return(x@fcsinfo[["RFACSadd>>$PnR"]][(pos.index[-1])])

617

}

618

}

619

} else {

620

if (!(i %in% c("$MODE", "$TOT", "$PAR"))){

621

warning("The Slot Name cannot be found in the metadata.")

622

return(NULL)

623

} else {

624

if (i=="$MODE"){

625

return(x@mode)

626

}

627

if (i=="$TOT"){

628

if (x@original==TRUE){

629

return(x@size)

630

} else {

631

return(x@fcsinfo[["RFACSadd>>$TOT"]])

632

}

633

}

634

if (i=="$PAR"){

635

if (x@original==TRUE){

636

return(x@nparam)

637

} else {

638

return(x@fcsinfo[["RFACSadd>>$PAR"]])

639

}

640

}

641

}

642

643

644

}

645

}

646

}

647

}

648

}

649

} ## is.character(i)

650

651

if (is.numeric(i)){

652

## JYW: will do it the long way, without x@metadata[[i]]

653

## will only return value if all of the indices are found in the fcsinfo

654

655

index.i <- i %in% 1:length(x@fcsinfo)

656

657

if (sum(index.i==1) != length(i)){

658

warning("Part or all of the Index cannot be found in the metadata.")

659

if (sum(index.i==1)==0){

660

return(NULL)

661

}

662

}

663

return(x@fcsinfo[i[index.i==1]])

664

}

665

}

666

667

668

})

669

670

### LIST OF KEY METADATA WORDS/slotnames

671

## NOTE: (single value of length 1 is returned unless otherwise noted in ())

672

## 1. mode, $MODE

673

## 2. size, $TOT

674

## 3. nparam, $PAR

675

## 4. shortnames (vector), $PnN (vector), $P1N, $P2N, ...

676

## 5. longnames (vector), $PnS(vector), $P1S, $P2S, ...

677

## 6. paramranges (vector), $PnR (vector), $P1R, $P2R

678

## 7. filename

679

## 8. objectname

680

## 9. original

681

## 10. fcsinfo (includes RFACSadd>> when the data

682

## is changed resulting in changes with #2-6 (above))

683

## 11. any other name will be added as a new slot

684

685

setReplaceMethod("[[",

686

signature(x="FCSmetadata"),

687

function(x,i,j,...,value) {

688

## "i" can ONLY be EITHER a single character input OR a vector of numeric values

689

## returns only a single slot if i=character

690

## returns list elements in "fcsinfo" if i=numeric

691

if ( !is.character(i) & !is.numeric(i)){

692

## i is neither numeric nor character

693

stop("Input index is neither character nor numeric.")

694

} else {

695

if (is.character(i)){

696

## try to find it in the metadata ...

697

## JYW: I opted not to do the nested if statements

698

## because they were hard to read for me...

699

700

## are there any slotnames?

701

702

## are there any fcsinfo slotnames?

703

if (length(i)>1){

704

stop("Only single entry for indexing by character slot name allowed.")

705

}

706

707

## original flag... needs work

708

709

if ( sum(i %in% slotNames(x))==1 ){

710

## need original checks for

711

## size, nparam, longnames, shortnames

712

if (x@original==FALSE){

713

if ( !(i %in% c("size", "nparam",

714

"longnames", "shortnames",

715

"paramranges"))){

716

slot(x,i) <- value

717

} else { ## depends on the false original flag

718

if (i == "size"){

719

x@fcsinfo[["RFACSadd>>$TOT"]] <- value

720

}

721

if ( i == "nparam"){

722

x@fcsinfo[["RFACSadd>>$PAR"]] <- value

723

}

724

if (i == "longnames"){

725

x@fcsinfo[["RFACSadd>>$PnS"]] <- value

726

}

727

if (i=="shortnames"){

728

x@fcsinfo[["RFACSadd>>$PnN"]] <- value

729

}

730

731

if (i=="paramranges"){

732

x@fcsinfo[["RFACSadd>>$PnR"]] <- value

733

}

734

735

}

736

} else { ## x@original is TRUE

737

slot(x, i) <- value

738

}

739

} else {

740

741

if ( sum(i %in% names(x@fcsinfo))==1) {

742

x@fcsinfo[[which(names(x@fcsinfo)==i)]] <- value

743

} else {

744

if (sum(i %in% c("$PnS",

745

unlist(strsplit(paste("$P",

746

1:x@nparam,

747

"S", sep="", collapse=","),

748

split=","))))==length(i)){

749

pos.index <- c("$PnS",

750

unlist(strsplit(paste("$P", 1:x@nparam,

751

"S", sep="", collapse=","),

752

split=","))) %in% i

753

if (x@original==TRUE){

754

if (pos.index[1]==TRUE){

755

756

x@longnames <- value

757

758

} else {

759

x@longnames[(pos.index[-1])] <- value

760

}

761

} else { ## x@original == FALSE

762

if (pos.index[1]==TRUE){

763

764

x@fcsinfo[["RFACSadd>>$PnS"]] <- value

765

766

} else {

767

x@fcsinfo[["RFACSadd>>$PnS"]][(pos.index[-1])] <- value

768

}

769

}

770

771

} else {

772

if (sum(i %in% c("$PnN",

773

unlist(strsplit(paste("$P",

774

1:x@nparam,

775

"N", sep="", collapse=","),

776

split=","))))==length(i)){

777

pos.index <- c("$PnN", unlist(strsplit(paste("$P", 1:x@nparam,

778

"N", sep="", collapse=","),

779

split=","))) %in% i

780

if (x@original==TRUE){

781

if (pos.index[1]==TRUE){

782

x@shortnames <- value

783

} else {

784

x@shortnames[(pos.index[-1])] <- value

785

}

786

} else{ ## if (x@original==FALSE)

787

if (pos.index[1]==TRUE){

788

x@fcsinfo[["RFACSadd>>$PnN"]] <- value

789

} else {

790

x@fcsinfo[["RFACSadd>>$PnN"]][(pos.index[-1])] <- value

791

}

792

}

793

} else {

794

if (sum(i %in% c("$PnR",

795

unlist(strsplit(paste("$P",

796

1:x@nparam,

797

"R", sep="", collapse=","),

798

split=","))))==length(i)){

799

pos.index <- c("$PnR", unlist(strsplit(paste("$P", 1:x@nparam,

800

"R", sep="", collapse=","),

801

split=","))) %in% i

802

if (x@original==TRUE){

803

if (pos.index[1]==TRUE){

804

x@paramranges <- value

805

} else {

806

x@paramranges[(pos.index[-1])] <- value

807

}

808

} else {## if (x@original==FALSE)

809

if (pos.index[1]==TRUE){

810

x@fcsinfo[["RFACSadd>>$PnR"]] <- value

811

} else {

812

x@fcsinfo[["RFACSadd>>$PnR"]][(pos.index[-1])] <- value

813

}

814

}

815

} else {

816

if (!(i %in% c("$MODE", "$TOT", "$PAR"))){

817

## cannot be found, so we make a new slot

818

len <- length(x@fcsinfo)

819

x@fcsinfo[[len+1]] <- value

820

## we do not have the RFACSadd>> prefix when just

821

## changing/adding on to the metadata

822

names(x@fcsinfo)[len+1] <- i ##paste("RFACSadd>>", i, sep="")

823

824

825

} else {

826

if (i=="$MODE"){

827

x@mode <- value

828

}

829

if (i=="$TOT"){

830

if (x@original==TRUE){

831

x@size <- value

832

} else {

833

x@fcsinfo[["RFACSadd>>$TOT"]] <- value

834

}

835

}

836

if (i=="$PAR"){

837

if (x@original==TRUE){

838

x@nparam <- value

839

} else {

840

x@fcsinfo[["RFACSadd>>$PAR"]] <- value

841

}

842

}

843

}

844

845

846

}

847

}

848

}

849

}

850

}

851

} ## is.character(i)

852

853

if (is.numeric(i)){

854

## JYW: will do it the long way, without x@metadata[[i]]

855

## will only return value if all of the indices are found in the fcsinfo

856

857

index.i <- i %in% 1:length(x@fcsinfo)

858

859

if (sum(index.i==1) !=length(i)){

860

warning("Part or all of the Index cannot be found in the metadata.")

861

862

}

863

x@fcsinfo[i[index.i==1]] <- value

864

}

865

}

866

867

868

x

869

870

871

})

872

## NOTE: [[<- for FCSmetdata

873

## can replace via numeric index with a value that is a list or vector

874

## ie. ex.s4@metadata[[c(1,100000)]]<-c("g", "wrong") or list("g", "wrong")

875

876

877

####################################

878

## FCS Class

879

####################################

880

## Methods include:

881

## 1. as.matrix(FCS)

882

## 2. as.data.frame(FCS)

883

## 3. as.FCS(matrix)

884

## 4. as.FCS(data.frame)

885

## 5. dim.FCS(FCS)

886

## 6. show

887

## 7. print

888

## 8. plot

889

## 9. summary

890

## 10. initialize

891

## 11. metaData

892

## 12. fluors

893

## 13. [ extracts data

894

## 14. [ <- replaces data

895

## 15. [[ extracts metadata

896

## 16. [[ <- replaces the metadata

897

## 17. is.FCS

898

## 18. addParameter

899

## 19. checkvars

900

## 20. fixvars

901

## 21. equals (are two FCS objects the same)

902

###################################

903

904

####################################

905

## Examples have been checked?

906

907

###

908

### Data from an FCS file

909

###

910

911

setClass("FCS",

912

representation(data="matrix", # flour data

913

metadata="FCSmetadata"),

914

prototype=list(data=matrix(),

915

metadata=new("FCSmetadata")))

916

917

918

919

setAs(from="FCS",to="matrix", ## as.matrix(FCS)

920

def=function(from) {

921

## createFCSnamesFromMetadata(x)

922

## colnames(x..) <- x@metat

923

from@data

924

})

925

926

927

setAs(from="FCS",to="data.frame",

928

def=function(from) {

929

## createFCSnamesFromMetadata(x)

930

## colnames(x..) <- x@metat

931

as.data.frame(from@data)

932

})

933

934

935

setAs(from="matrix",to="FCS",

936

def=function(from) {

937

## createFCSnamesFromMetadata(x)

938

## colnames(x..) <- x@metat

939

new("FCS",data=from)

940

})

941

942

943

setAs(from="data.frame",to="FCS",

944

def=function(from) {

945

## createFCSnamesFromMetadata(x)

946

## colnames(x..) <- x@metat

947

new("FCS",data=as.matrix(from))

948

})

949

950

setGeneric("dim.FCS",

951

function(object) {

952

standardGeneric("dim.FCS")

953

})

954

955

956

setMethod("dim.FCS",

957

signature(object="FCS"),

958

function(object) {

959

dim(object@data)

960

})

961

962

963

964

setMethod("show",

965

signature(object="FCS"),

966

function(object) {

967

object

968

## JYW: the is.list(object) does not

969

## correctly identify it being a S3 object

970

971

## if (!is.list(object)) {

972

orig.stat <- ifelse(object@metadata@original==TRUE,

973

"Original", "Non-original")

974

FourSpace <- " "

975

cat(FourSpace, orig.stat,

976

"Object of class `FCS' from:",

977

(object@metadata)@filename,"\n")

978

cat(FourSpace,

979

"Object name:",

980

(object@metadata)@objectname,"\n")

981

982

if (length(as.vector(object@data))==0){

983

cat(FourSpace,

984

"Dimensions","0",

985

"by","0","\n")

986

} else if (length(as.vector(object@data))==1){

987

if (!is.na(object@data) ){

988

cat(FourSpace,

989

"Dimensions",dim(object@data)[1],

990

"by",dim(object@data)[2],"\n")

991

} else {

992

cat(FourSpace,

993

"Dimensions","0",

994

"by","0","\n")

995

}

996

} else {

997

cat(FourSpace,

998

"Dimensions",dim(object@data)[1],

999

"by",dim(object@data)[2],"\n")

1000

}

1001

## } else {

1002

## S3 class...

1003

## print3.FCS(object)

1004

## }

1005

})

1006

1007

setMethod("print",

1008

signature(x="FCS"),

1009

function(x) {

1010

show(x)

1011

})

1012

1013

1014

setMethod("plot",

1015

signature(x="FCS",y="missing"),

1016

function(x,image.parallel.plot=FALSE, joint=TRUE,...) {

1017

## default is pairs plotting but should also be able to do parallel coordinates plotting

1018

1019

## variable decription

1020

##-----------------------------------

1021

## x FCS object

1022

##

1023

## image parallel.plot boolean; if true the image parallel coordinates

1024

## plot will be implemented instead of default

1025

## pairs plot; default value of FALSE

1026

## joint boolean; if image.parallel.plot is TRUE, then this boolean establishes

1027

## if the image parallel coordinates plot is joint or not

1028

## ... more options for pairs.CSP, when parallel.plot=FALSE

1029

1030

if (length(as.vector(x@data))==0){

1031

stop("There is no data to plot")

1032

} else if (length(as.vector(x@data))==1) {

1033

if (is.na(x@data)){

1034

stop("There is no data to plot")

1035

}

1036

}

1037

1038

if (image.parallel.plot==TRUE){

1039

if (joint==FALSE){

1040

ImageParCoord(x@data, ...)

1041

}

1042

else {

1043

JointImageParCoord(x@data, ...)

1044

}

1045

}

1046

else{

1047

pairs.CSP(x@data, ...)

1048

}

1049

})

1050

1051

setClass("FCSsummary",

1052

representation(num.cells="numeric",

1053

num.param="numeric",

1054

univariate.stat="matrix",

1055

metadata.info="list"),

1056

prototype=list(num.cells=0,

1057

num.param=0, univariate.stat=matrix(),

1058

metadata.info=list()))

1059

1060

setMethod("show",

1061

signature(object="FCSsummary"),

1062

function(object){

1063

cat("\n",

1064

"I. Data reports:",

1065

"\n\n")

1066

cat(paste(" A. Dimension Check: Dimensions: (row X col):",

1067

object@num.cells, "X",

1068

object@num.param,

1069

"\n",

1070

sep=" "))

1071

1072

cat(paste("\n",

1073

" B. Data Column Names & Univariate Summary:",

1074

"\n",

1075

sep=""))

1076

cat(" Using Tukey's method for the five number summary", "\n")

1077

print(object@univariate.stat)

1078

cat("\n")

1079

1080

1081

cat("\n",

1082

"II. Metadata Variable/Slot reports:",

1083

"\n")

1084

1085

cat(" A. Metadata Slots:",

1086

"\n")

1087

1088

1089

print(object@metadata.info$Description)

1090

cat("\n")

1091

1092

print(object@metadata.info$ColumnParametersSummary)

1093

cat("\n")

1094

1095

cat(" B. Metadata 'fcsinfo' slot length=",

1096

length(object@metadata.info$fcsinfoNames),

1097

" & slot names: \n\n")

1098

1099

1100

print(object@metadata.info$fcsinfoNames)

1101

1102

1103

cat("\n")

1104

1105

})

1106

1107

setMethod("print",

1108

signature(x="FCSsummary"),

1109

function(x){

1110

show(x)

1111

1112

})

1113

1114

1115

setMethod("summary",

1116

signature(object="FCS"),

1117

function(object) {

1118

1119

cat("\n")

1120

cat("I. Data reports:\n\n")

1121

if (length(as.vector(object@data))==0){

1122

cat("No Data", "\n\n")

1123

ranges.data <- NULL

1124

n.col <- n.row <- 0

1125

} else {

1126

if (length(as.vector(object@data))==1) {

1127

if (is.na(object@data)){

1128

cat("No Data", "\n")

1129

ranges.data <- NULL

1130

n.col <- n.row <- 0

1131

} else {

1132

cat("Single data value=",

1133

as(object@data, "matrix"),

1134

"\n\n")

1135

ranges.data <- range(object@data)

1136

n.col <- n.row <- 1

1137

}

1138

} else {

1139

n.row <- dim.FCS(object)[1]

1140

n.col <- dim.FCS(object)[2]

1141

1142

cat(paste(" A. Dimension Check: Dimensions: (row X col):",

1143

n.row, "X",

1144

n.col,

1145

"\n",

1146

sep=" "))

1147

1148

cat(paste("\n",

1149

" B. Data Column Names & Univariate Summary:",

1150

"\n",

1151

sep=""))

1152

cat(" Using Tukey's method for the five number summary",

1153

"\n")

1154

ranges.data <- t(apply(object@data, 2,

1155

function(x) {

1156

round(c(fivenum(x),

1157

mean(x),

1158

sd(x)), 3)

1159

}))

1160

1161

ranges.data <- cbind(1:length(ranges.data[,1]),

1162

ranges.data)

1163

colnames(ranges.data) <- c("column", "min",

1164

"lower-hinge", "median",

1165

"upper-hinge", "max", "mean", "sd")

1166

print(ranges.data)

1167

cat("\n")

1168

}

1169

}

1170

cat("\n",

1171

"II. Metadata Variable/Slot reports:",

1172

"\n")

1173

1174

cat(" A. Metadata Slots:",

1175

"\n")

1176

slotnames <- c("mode",

1177

"size/$TOT",

1178

"nparam/$PAR",

1179

"shortnames/$PnN",

1180

"longnames/$PnS",

1181

"paramranges/$PnR",

1182

"filename",

1183

"objectname",

1184

"original",

1185

"fcsinfo")

1186

description <- c("Mode",

1187

"number of cells/rows",

1188

"number of column params",

1189

"Shortnames of column parameters",

1190

"Longnames of column parameters",

1191

"Ranges/max of column parameters",

1192

"original FCS filename",

1193

"name of current object",

1194

"current object original status",

1195

"misc. metadata info")

1196

1197

values <- c(object[["mode"]],

1198

object[["size"]],

1199

object[["nparam"]],

1200

"see below",

1201

"see below",

1202

"see below",

1203

object[["filename"]],

1204

object[["objectname"]],

1205

object[["original"]],

1206

"see part II B.")

1207

tot.info <- data.frame(cbind(slotnames, description, values))

1208

print(tot.info)

1209

cat("\n")

1210

col.stuff <- cbind(object[["shortnames"]],

1211

object[["longnames"]],

1212

object[["paramranges"]])

1213

colnames(col.stuff) <- c("$PnN", "$PnS", "$PnR")

1214

col.stuff <- list("ColumnParametersSummary"=col.stuff)

1215

print(col.stuff)

1216

cat("\n")

1217

1218

cat(" B. Metadata 'fcsinfo' slot length=",

1219

length(object@metadata@fcsinfo), " & slot names: \n\n")

1220

1221

1222

fcsinfo.stuff <- list("fcsinfoNames"=names(object[["fcsinfo"]]))

1223

1224

1225

print(fcsinfo.stuff)

1226

1227

if (is.null(ranges.data)){

1228

ranges.data <- matrix()

1229

}

1230

1231

cat("\n")

1232

result <- new("FCSsummary", num.cells=n.row, num.param=n.col,

1233

univariate.stat=ranges.data,

1234

metadata.info=c("Description"=list(tot.info), col.stuff, fcsinfo.stuff))

1235

## MIXING S3 and S4

1236

## class(result) <- "summary.FCS"

1237

1238

## now there is no mixing of the S3 and S4 classes

1239

invisible(result)

1240

})

1241

1242

#setMethod("initialize",

1243

# signature(.Object="FCS"),

1244

# function(.Object) {

1245

# ## test

1246

# })

1247

1248

setGeneric("metaData",

1249

function(x) {

1250

standardGeneric("metaData")

1251

})

1252

1253

1254

setMethod("metaData",

1255

signature(x="FCS"),

1256

function(x) {

1257

x@metadata

1258

})

1259

1260

setGeneric("fluors",

1261

function(x) {

1262

standardGeneric("fluors")

1263

})

1264

1265

1266

setMethod("fluors",

1267

signature(x="FCS"),

1268

function(x) {

1269

x@data

1270

})

1271

1272

## index data

1273

setMethod("[",

1274

signature(x = "FCS"),

1275

function (x, i, j, ..., drop) {

1276

if(missing(j) ) {

1277

if( missing(i) ) { ## i, j is missing

1278

nexprs <- fluors(x)

1279

1280

} else { ## i present, j missing

1281

nexprs <- fluors(x)[i, ,drop=FALSE]

1282

1283

}

1284

pos <- 1:(dim.FCS(x)[2])

1285

} else {

1286

if( missing(i) ) { ## j is present

1287

nexprs <- fluors(x)[,j, drop=FALSE]

1288

} else {

1289

nexprs <- fluors(x)[i, j, drop=FALSE]

1290

}

1291

pos <- j

1292

}

1293

## JYW: need to update the metadata with fixvars?

1294

x <- new("FCS",data=nexprs,metadata=metaData(x))

1295

## the data has changed so we

1296

## update the metadata

1297

1298

x[["RFACSadd>>$TOT"]] <- dim.FCS(x)[1]

1299

x[["RFACSadd>>$PAR"]] <- dim.FCS(x)[2]

1300

## must be able to check against data range that is NA, (work up example)

1301

1302

x[["RFACSadd>>$PnR"]] <- unlist(apply(x@data, 2, max))

1303

x[["RFACSadd>>$PnS"]] <- x@metadata@longnames[pos]

1304

x[["RFACSadd>>$PnN"]] <- x@metadata@shortnames[pos]

1305

x[["original"]] <- FALSE

1306

x

1307

})

1308

1309

1310

## index data. NEEDS VERIFICATION

1311

setReplaceMethod("[",

1312

signature(x = "FCS"),

1313

function (x, i, j, ..., value) {

1314

## the names do not change b/c we return the whole FCS R object

1315

x[["RFACSadd>>$PnS"]] <- x@metadata@longnames

1316

x[["RFACSadd>>$PnN"]] <- x@metadata@shortnames

1317

1318

nexprs <- fluors(x)

1319

1320

if(missing(j) ) {

1321

if( missing(i) ) { ## i, j is missing

1322

nexprs <- value ## nexprs <- flours(x)

1323

} else { ## i present, j missing

1324

nexprs[i,] <- value ## nexprs <- flours(x)[i, ,drop=FALSE]

1325

}

1326

1327

} else {

1328

if( missing(i) ) { ## j is present

1329

nexprs[,j] <- value ## nexprs <- flours(x)[,j, drop=FALSE]

1330

} else {

1331

nexprs[i,j] <- value ## nexprs <- flours(x)[i, j, drop=FALSE]

1332

}

1333

1334

}

1335

## JYW: need to update the metadata with fixvars?

1336

x <- new("FCS",data=nexprs,metadata=metaData(x))

1337

1338

## the data has changed so we

1339

## update the metadata

1340

1341

x[["RFACSadd>>$TOT"]] <- dim.FCS(x)[1]

1342

x[["RFACSadd>>$PAR"]] <- dim.FCS(x)[2]

1343

## must be able to check against data range that is NA, (work up example)

1344

1345

x[["RFACSadd>>$PnR"]] <- unlist(apply(x@data, 2, max))

1346

1347

x[["original"]] <- FALSE

1348

1349

x

1350

})

1351

1352

1353

1354

## JYW: I am doing this as the reiteration of the metadata extraction

1355

setMethod("[[",

1356

signature(x="FCS"),

1357

function(x,i,j,...,drop) {

1358

## "i" can ONLY be EITHER a single character input OR a vector of numeric values

1359

## returns only a single slot if i=character

1360

## returns list elements in "fcsinfo" if i=numeric

1361

1362

x@metadata[i]

1363

1364

})

1365

1366

1367

1368

1369

setReplaceMethod("[[",

1370

signature(x="FCS"),

1371

function(x,i,j,...,value) {

1372

## "i" can ONLY be EITHER a single character input OR a vector of numeric values

1373

## returns only a single slot if i=character

1374

## returns list elements in "fcsinfo" if i=numeric

1375

1376

x@metadata[i] <- value

1377

x

1378

})

1379

1380

1381

#######

1382

####### METHODS by JYW (ie, first pass, may break)

1383

#######

1384

1385

## use:

1386

## is(FCSobject,"FCS")

1387

1388

## adds a column parameter to the data of the FCS function

1389

1390

setGeneric("addParameter",

1391

function(x, colvar, shortname="",

1392

longname="", use.shortname=FALSE) {

1393

standardGeneric("addParameter")

1394

})

1395

1396

1397

## if use.shortname is TRUE then the shortname

1398

## will be concatenated to the original datanames

1399

1400

setMethod("addParameter",

1401

signature(x="FCS",

1402

colvar="vector"),

1403

function(x, colvar,

1404

shortname="",

1405

longname="",

1406

use.shortname=FALSE){

1407

if (length(colvar)!=dim.FCS(x)[1]){

1408

stop(paste("Input Parameter vector length",

1409

length(colvar),

1410

"does not correspond to FCS data column length",

1411

dim.FCS(x)[1], sep=","))

1412

}

1413

if (length(as.vector(x@data))==0){

1414

x@data <- matrix(colvar, ncol=1)

1415

} else if (length(as.vector(x@data))==1){

1416

if (is.na(x@data)){

1417

x@data <- matrix(colvar, ncol=1)

1418

} else {

1419

x@data <- cbind(x@data, colvar)

1420

}

1421

} else {

1422

## update the data

1423

x@data <- cbind(x@data, colvar)

1424

}

1425

col.pos <- dim(x@data)[2]

1426

1427

if (!use.shortname){

1428

colnames(x@data)[col.pos] <- longname

1429

} else {

1430

colnames(x@data)[col.pos] <- shortname

1431

}

1432

## update the metadata

1433

1434

x[["RFACSadd>>$TOT"]] <- dim.FCS(x)[1]

1435

x[["RFACSadd>>$PAR"]] <- dim.FCS(x)[2]

1436

## must be able to check against data range that is NA, (work up example)

1437

1438

range.colvar <- ifelse(is.numeric(colvar), max(as.numeric(colvar)), NA)

1439

x[["RFACSadd>>$PnR"]] <- c(x[["paramranges"]], range.colvar)

1440

x[["RFACSadd>>$PnS"]] <- c(x[["longnames"]], longname)

1441

x[["RFACSadd>>$PnN"]] <- c(x[["shortnames"]], shortname)

1442

x[["original"]] <- FALSE

1443

x

1444

})

1445

1446

1447

1448

setGeneric("checkvars",

1449

function(x,

1450

MY.DEBUG=TRUE,

1451

range.max=NULL) {

1452

standardGeneric("checkvars")

1453

})

1454

1455

1456

1457

setMethod("checkvars",

1458

signature(x = "FCS"),

1459

## not sure if the signature is corrects

1460

function (x, MY.DEBUG=TRUE, range.max=NULL) {

1461

1462

## PURPOSE:

1463

## Will check the following:

1464

## 1. Number of observations & number of parameters

1465

## 2. Range of Data

1466

## 3. Names of Data

1467

1468

## Use 'fixvars' to fix metadata based on data

1469

1470

1471

pass.check <- NULL

1472

1473

1474

## A. Some initial checks

1475

1476

1477

## Is this an FCS class object?

1478

if (!is(x, "FCS")) {

1479

1480

## will return FALSE and get out of the function

1481

warning("Bad input; not of class FCS")

1482

return(FALSE)

1483

1484

} else {

1485

if (MY.DEBUG){

1486

print("Class is FCS")

1487

}

1488

}

1489

1490

## Is there any data?

1491

if (length(as.vector(fluors(x)))==0){

1492

warning("FCS object does not have data")

1493

return(FALSE)

1494

} else if (length(as.vector(fluors(x)))==1){

1495

if (is.na(fluors(x))) {

1496

## will return FALSE and get out of the function

1497

warning("FCS object does not have data")

1498

return(FALSE)

1499

1500

} else {

1501

if (MY.DEBUG) {

1502

print("Object has data")

1503

}

1504

}

1505

} else { ## length is not 0 or 1

1506

1507

if (MY.DEBUG) {

1508

print("Object has data")

1509

}

1510

}

1511

1512

## Is there metadata?

1513

if (is.null(metaData(x)) ) {

1514

## will return FALSE and get out of the function

1515

1516

warning("FCS object does not have data")

1517

return(FALSE)

1518

} else {

1519

if (MY.DEBUG) {

1520

print("Object has metadata")

1521

}

1522

}

1523

1524

## Is there an object name?

1525

if (x@metadata@objectname=="" || is.null(x@metadata@objectname) || (x@metadata@objectname=="None")) {

1526

if(MY.DEBUG){

1527

print("Object does not have a name.")

1528

}

1529

} else {

1530

if (MY.DEBUG) {

1531

print(paste("Object has a name:",x@metadata@objectname, sep="") )

1532

}

1533

}

1534

1535

## We extract the necessary data and metadata

1536

## for the checks.

1537

1538

## If the object is not the original

1539

## we check RFACSadd parameters.

1540

1541

## If the object is the original

1542

## we check for the original parameter names.

1543

1544

## The original flag of the metadata is only changed

1545

## when using the 'ExtractGatedData'. Using [, [<-

1546

## will not change the original flag of the metadata.

1547

1548

## if the non original parameters cannot be found,

1549

## then the check is skipped.

1550

1551

1552

1553

## The following should work by itself 2/20/04

1554

meta.size<-x[["size"]]

1555

meta.nparam<-x[["nparam"]]

1556

1557

1558

1559

## After initial checks, we

1560

## are able to continue other

1561

## checks mentioned in the purpose.

1562

1563

## B. Checking the $TOT (number of rows)

1564

## and $PAR (the number of columns)

1565

1566

1567

## initialize checks to NULL

1568

row.check <- col.check <- NULL

1569

1570

## if $TOT and $PAR are not in the metadata

1571

## set the checks to FALSE

1572

1573

if (is.null(meta.size) == TRUE) {

1574

row.check <- FALSE

1575

}

1576

1577

if (is.null(meta.nparam) == TRUE) {

1578

col.check <- FALSE

1579

}

1580

1581

## make the row and column checks if they are still

1582

## NULL

1583

1584

if (is.null(row.check)==TRUE){

1585

row.check <- ifelse(dim.FCS(x)[1]==meta.size,

1586

TRUE, FALSE)

1587

}

1588

1589

if (is.null(col.check)==TRUE){

1590

col.check <- ifelse(dim.FCS(x)[2]==meta.nparam,

1591

TRUE, FALSE)

1592

}

1593

1594

## Initial check

1595

if (MY.DEBUG == TRUE) {

1596

print("Data Dimension Check: Dimensions: (row X col)")

1597

print(paste(" ", "Data: (",

1598

dim.FCS(x)[1], " X ",

1599

dim.FCS(x)[2], ")", sep=""))

1600

print(paste(" ", "Metadata: (",

1601

meta.size,

1602

" X ", meta.nparam,

1603

")", sep=""))

1604

1605

}

1606

## IF there are FALSE checks:

1607

## 1. print out the debugging statement

1608

## if indicated by MY.DEBUG

1609

1610

1611

if (row.check == FALSE) {

1612

if (MY.DEBUG == TRUE) {

1613

print(" Row number ($TOT/size) mismatch.")

1614

}

1615

1616

}

1617

1618

if (col.check == FALSE) {

1619

if (MY.DEBUG == TRUE) {

1620

print(" Column number ($PAR/nparam) mismatch.")

1621

}

1622

}

1623

## JYW Question:

1624

## Do we also need to remove all metadata parameters

1625

## that have an index greater than $PAR

1626

## no just comment that they are probably invalid in the docs

1627

1628

1629

1630

## checks: row.check ; col.check

1631

1632

1633

## C. Checking the names only if the column dimensions

1634

## If there is a difference, then the metadata

1635

## names are changed to that of the data

1636

1637

if (length(x[["longnames"]])==0){

1638

longnames.metadata <- rep(NA, dim.FCS(x)[2])

1639

} else {

1640

longnames.metadata <- x[["longnames"]]

1641

}

1642

if (length(x[["shortnames"]])==0){

1643

shortnames.metadata <- rep(NA, dim.FCS(x)[2])

1644

} else {

1645

## we obtain the shortnames of the metadata

1646

1647

shortnames.metadata <- x[["shortnames"]]

1648

}

1649

## We obtain the names in the data

1650

names.data <- colnames(fluors(x))

1651

## We note in which names in the data are NA

1652

1653

if (!is.null(names.data)){

1654

names.data.na <- which(is.na(names.data))

1655

if (length(names.data.na)==0){

1656

names.data.na <- NULL

1657

}

1658

} else {

1659

names.data.na <- 1:(dim.FCS(x)[2])

1660

names.data <- rep(NA, dim.FCS(x)[2])

1661

}

1662

1663

names.check <- original.stat.check <- TRUE

1664

## if the lengths do not match up

1665

if ((length(names.data)!=length(longnames.metadata)) ||

1666

(length(names.data)!=length(shortnames.metadata)) ){

1667

## there might be something wrong with the original status

1668

1669

x[["original"]] <- ifelse(x[["original"]]==TRUE, FALSE, TRUE)

1670

longnames.metadata <- x[["longnames"]]

1671

shortnames.metadata <- x[["shortnames"]]

1672

if ((length(names.data)!=length(longnames.metadata)) ||

1673

(length(names.data)!=length(shortnames.metadata)) ){

1674

1675

names.check <- FALSE

1676

##

1677

} else {

1678

if (MY.DEBUG){

1679

print(paste("Error Names length mismatch: x@metadata@original Status should be:",

1680

x[["original"]], sep=" "))

1681

original.stat.check <- FALSE

1682

}

1683

1684

}

1685

## change back to the previous original status

1686

x[["original"]] <- ifelse(x[["original"]]==TRUE, FALSE, TRUE)

1687

used.var <- paste( x@metadata@objectname,"@metadata@longnames", sep="")

1688

o.names.used <- longnames.metadata <- x[["longnames"]]

1689

}

1690

1691

if (original.stat.check & names.check){

1692

## note: metadata names are NA if they are missing

1693

long.na <- which(is.na(longnames.metadata))

1694

if (length(long.na)==0){

1695

long.na <- NULL

1696

}

1697

longnames.var <- unlist(strsplit(paste("$P",

1698

1:(dim.FCS(x)[2]),

1699

"S", sep="",

1700

collapse=","),

1701

split=","))

1702

1703

1704

1705

## note: metadata names are NA if they are missing

1706

short.na <- which(is.na(shortnames.metadata))

1707

if (length(short.na)==0){

1708

short.na <- NULL

1709

}

1710

1711

shortnames.var <- unlist(strsplit(paste("$P",

1712

1:(dim.FCS(x)[2]),

1713

"N", sep="",

1714

collapse=","),

1715

split=","))

1716

1717

## NOTE: we will change the missing metadata names to "None"

1718

if (!is.null(long.na) ){

1719

longnames.metadata[long.na] <- rep("None", length(long.na))

1720

}

1721

1722

if (!is.null(short.na) ){

1723

shortnames.metadata[short.na] <- rep("None", length(short.na))

1724

}

1725

1726

## we will change the metadata names to NA if data names are NA

1727

if (!is.null(names.data.na) & length(names.data.na)!=0){

1728

longnames.metadata[names.data.na] <- rep(NA, length(names.data.na))

1729

shortnames.metadata[names.data.na] <- rep(NA, length(names.data.na))

1730

}

1731

1732

## here we check the nonmissing data names

1733

## the data's names that are NOT NA

1734

long.pos.chk <- ifelse(1:length(longnames.metadata) %in% c(names.data.na), 0, 1)

1735

short.pos.chk <- ifelse(1:length(shortnames.metadata) %in% c(names.data.na), 0,1)

1736

long.match <- short.match <- NULL

1737

long.match[long.pos.chk==1] <- ifelse(names.data[long.pos.chk==1]==longnames.metadata[long.pos.chk==1],

1738

1, 0)

1739

long.match[long.pos.chk==0] <- 1 ## the NA's are skipped in the check

1740

short.match[short.pos.chk==1] <- ifelse(names.data[short.pos.chk==1]==shortnames.metadata[short.pos.chk==1],

1741

1, 0)

1742

short.match[short.pos.chk==0] <- 1 ## NA's as skipped in the check

1743

1744

## we will compare against the longnames of the metadata if there

1745

## are more or equal number of matches comparing the data's names with the longnames

1746

## we will compare against the shortnames of the metadata if there

1747

## are more matches of the data's names with the longnames

1748

1749

1750

if (sum(long.match)>=sum(short.match)){

1751

## longnames are used

1752

used.var <- paste(x@metadata@objectname,"@metadata@longnames", sep="")

1753

used.metadata.names <- longnames.var

1754

1755

used.match <- long.match

1756

1757

names.used <- longnames.metadata

1758

o.names.used <- x[["longnames"]]

1759

1760

} else {

1761

## shortnames are used

1762

used.var <- paste( x@metadata@objectname,"@metadata@shortnames", sep="")

1763

used.metadata.names <- shortnames.var

1764

1765

used.match <- short.match

1766

1767

names.used <- shortnames.metadata

1768

o.names.used <- x[["shortnames"]]

1769

1770

}

1771

1772

1773

1774

match.pos.fix <- which(used.match==0)

1775

if (length(match.pos.fix)==0){

1776

match.pos.fix <- NULL

1777

}

1778

1779

1780

fix.metadata.vars <- NULL

1781

1782

if (is.null(match.pos.fix)==FALSE || length(match.pos.fix) != 0){

1783

names.check <- FALSE

1784

1785

fix.metadata.vars <- used.metadata.names[match.pos.fix]

1786

1787

}

1788

}

1789

1790

if (MY.DEBUG == TRUE) {

1791

print("Names Check:")

1792

## print(paste(" ", "Data Parameter Names:", sep=" "))

1793

names.df.output <- cbind(names.data, o.names.used)

1794

colnames(names.df.output) <- c("Data Parameter Names", used.var)

1795

print(names.df.output)

1796

## for (i in 1:length(names.data)){

1797

## print(paste(" ", names.data[i]))

1798

## }

1799

## print(paste(" ", used.var, ":", sep=" "))

1800

## for (j in 1:length(o.names.used)){

1801

## print(paste(" ", o.names.used[j]))

1802

## }

1803

}

1804

1805

if (names.check==FALSE){

1806

## remark that there is a names discrepancy

1807

1808

if (MY.DEBUG == TRUE) {

1809

print(paste(" ", used.var,"do not match with that of the data.", sep=" "))

1810

1811

}

1812

}

1813

1814

## check: names.check

1815

1816

1817

## C. Fixing the ranges in the metadata

1818

1819

1820

metadata <- x@metadata@fcsinfo

1821

## an indicator of the RFACS heading, not used here

1822

1823

is.RFACS.metadata <- unlist(lapply(names(metadata), function(x) {

1824

total.char <- nchar(x)

1825

words <- unlist(strsplit(x, "RFACSadd>>"))

1826

is.RFACS <- NULL

1827

if (nchar(words[1]) < total.char) {

1828

is.RFACS <- TRUE

1829

} else if (nchar(words[1]) == total.char) {

1830

is.RFACS <- FALSE

1831

1832

}

1833

return(is.RFACS)

1834

}))

1835

## obtaining the ranges (max only) of the data

1836

ranges.data.o <- apply(fluors(x), 2, function(x){max(as.numeric(x))})

1837

ranges.data <- apply(fluors(x), 2, function(x) {

1838

if (!is.null(range.max)){

1839

if (max(as.numeric(x))<range.max){

1840

return(range.max)

1841

} else {

1842

return(max(as.numeric(x)))

1843

}

1844

} else {

1845

return(max(as.numeric(x)))

1846

}

1847

})

1848

1849

## do not check against the missing data ranges

1850

rng.data.idx <- !is.na(ranges.data)

1851

1852

## the metadata variables

1853

range.var <- as.vector(paste("$P", 1:(dim.FCS(x)[2]),

1854

"R", sep = ""))

1855

names(ranges.data) <- range.var

1856

1857

## getting the ranges of the metadata

1858

## that are indicated by metadata variable names

1859

## and are not RFACS

1860

1861

## we want to replace the regular $PiR with RFACSadd>>$PiR

1862

1863

## metadata <- metadata[is.RFACS.metadata == FALSE]

1864

ranges.metadata <-x[["$PnR"]]

1865

## if ranges.metadata not the size of ranges.data

1866

if (length(ranges.data) > length(ranges.metadata)){

1867

ranges.check <- FALSE

1868

## force the ranges.metadata to the same length

1869

diff.g <- length(ranges.data)-length(ranges.metadata)

1870

ranges.metadata <- c(ranges.metadata, rep(NA, diff.g))

1871

if (MY.DEBUG){

1872

print("Ranges of the Data is longer than Metadata.")

1873

}

1874

1875

}

1876

1877

if (length(ranges.data) < length(ranges.metadata)){

1878

ranges.check <- FALSE

1879

## force the ranges.metadata to the same length

1880

1881

ranges.metadata <- ranges.metadata[1:length(ranges.data)]

1882

if (MY.DEBUG){

1883

print("Ranges of the Metadata is longer than the Data.")

1884

print(" Only the first corresponding elements of the ")

1885

print(" metadata ranges are compared to the data.")

1886

}

1887

}

1888

1889

## find the missing metadata ranges

1890

missing.pos <- sapply(ranges.metadata, function(x) {

1891

ifelse(is.na(x) || is.null(x), 1, 0)

1892

})

1893

1894

num.missing <- sum(missing.pos, na.rm = TRUE)

1895

1896

if (num.missing > 0) {

1897

1898

if (MY.DEBUG == TRUE) {

1899

print(paste("Range Check: Range parameter(s) missing in the metadata:"))

1900

1901

1902

ms <- as.matrix(range.var[missing.pos == 1])

1903

colnames(ms) <- "Missing Ranges"

1904

print(ms)

1905

1906

1907

}

1908

}

1909

1910

ranges.info <- rbind(ranges.data,

1911

ranges.metadata)

1912

ranges.correct <- apply(ranges.info, 2, function(x) {

1913

x <- as.numeric(x)

1914

if (is.element(NA, x)) {

1915

return(0)

1916

} else {

1917

ifelse(x[1] <= x[2], 0, 1)

1918

}

1919

})

1920

ranges.correct <- ifelse(is.na(ranges.correct), 0, ranges.correct)

1921

1922

ranges.check <- sum(ranges.correct)==0

1923

1924

if (ranges.check==FALSE) {

1925

fix.range.var <- range.var[which(ranges.correct==1)]

1926

fix.range.data <- ranges.data[which(ranges.correct==1)]

1927

fix.range.meta <- ranges.metadata[which(ranges.correct==1)]

1928

1929

if (MY.DEBUG==TRUE){

1930

print("Ranges Check: Column parameters are NOT within the ranges specified in the metadata.")

1931

rng.df <- cbind(ranges.data.o, x[["paramranges"]])

1932

colnames(rng.df) <- c("Data Ranges", paste(x[["objectname"]], "@paramranges", sep=""))

1933

print(rng.df)

1934

}

1935

} else if (ranges.check==TRUE){

1936

if (MY.DEBUG == TRUE) {

1937

print("Range Check: Column parameters are within specified metadata range.")

1938

rng.df <- cbind(ranges.data.o, x[["paramranges"]])

1939

colnames(rng.df) <- c("Data Ranges", paste(x[["objectname"]], "@paramranges", sep=""))

1940

print(rng.df)

1941

1942

}

1943

}

1944

1945

1946

## check: ranges.check

1947

pass.check <- row.check & col.check & names.check & original.stat.check & ranges.check

1948

return(pass.check)

1949

})

1950

1951

1952

## try an example on a FCSgate object

1953

1954

setGeneric("fixvars",

1955

function(x, x.name="", range.max=NULL, MY.DEBUG=TRUE) {

1956

standardGeneric("fixvars")

1957

})

1958

1959

1960

setMethod("fixvars",

1961

signature(x = "FCS"),

1962

function (x,x.name="",range.max=NULL, MY.DEBUG=TRUE) {

1963

1964

## Upgraded to S4 class

1965

##---------------------------------

1966

1967

## PURPOSE:

1968

## Will check the following:

1969

## 1. Number of observations & number of parameters of the Data

1970

## 2. Range of Data

1971

## 3. Names of Data

1972

## Will compare 1-3 against the Metadata!

1973

1974

## If there is a discrepancy between the FCSdata

1975

## and FCSmetadata, then the metadata (ONLY) will

1976

## be changed.

1977

1978

## Relies on 'is.FCS' and 'setMetadata.FCS'(only for S3)

1979

1980

##-------------------------------------

1981

## A. Some initial checks

1982

##-------------------------------------

1983

1984

## Is this an FCS class object?

1985

if (!is(x, "FCS")) {

1986

stop("Bad input; not of class FCS")

1987

} else {

1988

if (MY.DEBUG){

1989

print("Class is FCS")

1990

}

1991

}

1992

1993

## Is there any data?

1994

if (length(as.vector(fluors(x)))==0){

1995

warning("FCS object does not have data")

1996

return(x)

1997

} else if (length(as.vector(fluors(x)))==1){

1998

if (is.na(fluors(x))) {

1999

## will return FALSE and get out of the function

2000

warning("FCS object does not have data")

2001

return(x)

2002

2003

} else {

2004

if (MY.DEBUG) {

2005

print("Object has data")

2006

}

2007

}

2008

} else { ## length is not 0 or 1

2009

2010

if (MY.DEBUG) {

2011

print("Object has data")

2012

}

2013

}

2014

2015

2016

2017

## Is there metadata? what if it is the default?????

2018

## the default is zero or empty lists

2019

## which can be updated in this function

2020

2021

if (is.null(metaData(x))) {

2022

## doubt this will ever happen

2023

warning("FCS object does not have metadata")

2024

x <- new(data=x@data, metadata=new("FCSmetadata"), "FCS")

2025

2026

} else {

2027

if (MY.DEBUG) {

2028

print("Object has metadata")

2029

}

2030

}

2031

exist.meta.objectname <- NULL

2032

## Is there an object name?

2033

if ((x@metadata@objectname=="") || (is.null(x@metadata@objectname)) || (x@metadata@objectname=="None")) {

2034

exist.meta.objectname<-FALSE

2035

} else {

2036

exist.meta.objectname <- TRUE

2037

}

2038

2039

2040

if (exist.meta.objectname==FALSE){

2041

if (x.name==""){

2042

if(MY.DEBUG){

2043

print("Object does not have a name.")

2044

print("User did not define an object name in x.name")

2045

print("Object will remain with no name")

2046

}

2047

} else if (x.name != "") { ## there is a name defined in x.name

2048

x@metadata@objectname <- x.name

2049

if (MY.DEBUG){

2050

print("Object does not have a name.")

2051

print(paste("User-defined x.name=", x.name, sep=""))

2052

print(paste("Object will have new name: ", x.name, sep=""))

2053

}

2054

}

2055

} else if (exist.meta.objectname==TRUE){

2056

if (x.name==""){

2057

if (MY.DEBUG) {

2058

print(paste("Object has a name: ",x[["objectname"]], sep="") )

2059

}

2060

} else if (x.name !=""){

2061

if (x[["objectname"]] != x.name) {

2062

x[["objectname"]] <- x.name

2063

if (MY.DEBUG){

2064

print(paste("Object has a name:",x[["objectname"]], sep="") )

2065

print(paste("User-defined x.name=", x.name, sep=""))

2066

print(paste("Object will have new name:", x.name, sep=""))

2067

}

2068

} else if (x[["objectname"]] == x.name){

2069

print(paste("Object has a name:",x[["objectname"]], sep="") )

2070

print(paste("User-defined x.name=", x.name, sep=""))

2071

}

2072

}

2073

}

2074

2075

##---------------------------

2076

## After initial checks, we

2077

## are able to continue other

2078

## checks mentioned in the purpose.

2079

##----------------------------

2080

2081

2082

2083

##-----------------------------------

2084

## C. Checking the $TOT (number of rows)

2085

## and $PAR (the number of columns)

2086

##-------------------------------------

2087

2088

## Initial check

2089

2090

2091

meta.size<-x[["size"]]

2092

meta.nparam<-x[["nparam"]]

2093

2094

if (MY.DEBUG == TRUE) {

2095

print("Data Dimension Check: Dimensions: (row X col)")

2096

print(paste(" ", "Data: (", dim.FCS(x)[1], " X ", dim.FCS(x)[2], ")", sep=""))

2097

print(paste(" ", "Metadata: (", meta.size, " X ", meta.nparam, ")", sep=""))

2098

2099

}

2100

2101

dim.incorrect.msg <- function(dim.name, dim.pos = c("1","2")) {

2102

## PURPOSE: Will print out a message that the

2103

## observations/rows ($TOT) or the number of parameters/

2104

## columns ($PAR) of the metadata do NOT match and

2105

## are changed to that of the data

2106

dim.pos <- as.numeric(match.arg(dim.pos))

2107

if (dim.pos == 1) {

2108

param <- meta.size

2109

param.name <- "rows/cells"

2110

} else if (dim.pos == 2) {

2111

param <- meta.nparam

2112

param.name <- "columns/parameters"

2113

}

2114

print(paste("Data Dimension Fix: The", dim.name, "of the metadata,",

2115

param, ",is incorrect will be set to the number of",

2116

param.name, "in the data,", dim.FCS(x)[dim.pos],

2117

sep = " "))

2118

2119

}

2120

2121

## initialize checks to NULL

2122

row.check <- col.check <- NULL

2123

2124

## if $TOT and $PAR are not in the metadata

2125

## set the checks to FALSE

2126

2127

if ((is.null(meta.size) == TRUE) || (meta.size==0) || (length(meta.size)==0) ) {

2128

row.check <- FALSE

2129

}

2130

2131

if (is.null(meta.nparam) == TRUE || (meta.nparam==0) || (length(meta.nparam)==0)){

2132

col.check <- FALSE

2133

}

2134

2135

## make the row and column checks if they are still

2136

## NULL

2137

2138

if (is.null(row.check)==TRUE){

2139

row.check <- ifelse(dim.FCS(x)[1]==meta.size,

2140

TRUE, FALSE)

2141

}

2142

2143

if (is.null(col.check)==TRUE){

2144

col.check <- ifelse(dim.FCS(x)[2]==meta.nparam,

2145

TRUE, FALSE)

2146

}

2147

2148

## IF there are FALSE checks:

2149

## 1. print out the debugging statement

2150

## if indicated by MY.DEBUG

2151

## 2. change the metadata ($TOT or $PAR) to the number

2152

## of rows or columns in the data

2153

2154

if (row.check == FALSE) {

2155

if (MY.DEBUG == TRUE) {

2156

dim.incorrect.msg("size", "1")

2157

}

2158

metadata.old.tot <- meta.size

2159

2160

x[["size"]] <- dim.FCS(x)[1]

2161

}

2162

2163

if (col.check == FALSE) {

2164

if (MY.DEBUG == TRUE) {

2165

dim.incorrect.msg("$PAR", "2")

2166

}

2167

metadata.old.par <- meta.nparam

2168

x[["nparam"]] <- dim.FCS(x)[2]

2169

2170

## JYW Question:

2171

## Do we also need to remove all metadata parameters

2172

## that have an index greater than $PAR;

2173

## ANS: no, just comment in docs, to beware

2174

2175

}

2176

2177

2178

## checks: row.check ; col.check

2179

2180

##-------------------------------------

2181

## B. Checking the names

2182

## If there is a difference, then the metadata

2183

## names are changed to that of the data

2184

##----------------------------------

2185

2186

2187

## B. Checking the names only if the column dimensions

2188

## If there is a difference, then the metadata

2189

## names are changed to that of the data

2190

2191

if (length(x[["longnames"]])==0){

2192

longnames.metadata <- rep(NA, dim.FCS(x)[2])

2193

} else {

2194

longnames.metadata <- x[["longnames"]]

2195

}

2196

if (length(x[["shortnames"]])==0){

2197

shortnames.metadata <- rep(NA, dim.FCS(x)[2])

2198

} else {

2199

shortnames.metadata <- x[["shortnames"]]

2200

2201

}

2202

## We obtain the names in the data

2203

names.data <- colnames(fluors(x))

2204

## We note in which names in the data are NA

2205

2206

if (!is.null(names.data)){

2207

names.data.na <- which(is.na(names.data))

2208

if (length(names.data.na)==0){

2209

names.data.na <- NULL

2210

}

2211

} else {

2212

names.data.na <- 1:(dim.FCS(x)[2])

2213

names.data <- rep(NA, dim.FCS(x)[2])

2214

}

2215

2216

########## WHAT IF longnames.metadata/shortnames.metadata

2217

## are not the same length as names.data

2218

###

2219

names.check <- original.stat.check <- TRUE

2220

## if the lengths do not match up

2221

if ((length(names.data)!=length(longnames.metadata)) ||

2222

(length(names.data)!=length(shortnames.metadata)) ){

2223

## there might be something wrong with the original status

2224

2225

x[["original"]] <- ifelse(x[["original"]]==TRUE, FALSE, TRUE)

2226

longnames.metadata <- x[["longnames"]]

2227

shortnames.metadata <- x[["shortnames"]]

2228

if ((length(names.data)!=length(longnames.metadata)) ||

2229

(length(names.data)!=length(shortnames.metadata)) ){

2230

2231

## names.check <- FALSE

2232

## change back to the previous original status

2233

x[["original"]] <- ifelse(x[["original"]]==TRUE, FALSE, TRUE)

2234

longnames.metadata <- x[["longnames"]]

2235

shortnames.metadata <- x[["shortnames"]]

2236

## concatenate the longer length or put in NAs and continue with name check

2237

if (length(x[["longnames"]]) > length(names.data)){

2238

2239

if (MY.DEBUG){

2240

print("metadata@longnames mismatch with data column names")

2241

mll <- as.matrix(x[["longnames"]])

2242

colnames(mll) <- "metadata@longname"

2243

print(mll)

2244

## print(paste(" metadata@longnames:", paste(x[["longnames"]], collapse=","), sep=" "))

2245

}

2246

x[["longnames"]] <- x[["longnames"]][1:length(names.data)]

2247

longnames.metadata <- x[["longnames"]]

2248

if (MY.DEBUG){

2249

print(paste(" will be concatenated:"))

2250

print(as.matrix(longnames.metadata))

2251

}

2252

} else {

2253

if (length(x[["longnames"]]) < length(names.data)){

2254

diff <- length(names.data)-length(x[["longnames"]])

2255

if (MY.DEBUG){

2256

print("metadata@longnames mismatch length with data column names")

2257

mll <- as.matrix(x[["longnames"]])

2258

colnames(mll) <- "metadata@longnames"

2259

print(mll)

2260

}

2261

x[["longnames"]] <- c(x[["longnames"]], rep(NA, diff))

2262

longnames.metadata <- x[["longnames"]]

2263

if (MY.DEBUG){

2264

print(paste(" will be changed to:"))

2265

print(as.matrix(longnames.metadata))

2266

}

2267

}

2268

}

2269

## concatenate the longer length or put in NAs and continue with name check

2270

if (length(x[["shortnames"]]) > length(names.data)){

2271

2272

if (MY.DEBUG){

2273

print("metadata@shortnames mismatch length with data column names")

2274

mss <- as.matrix(x[["shortnames"]])

2275

colnames(mss) <- "metadata@shortnames"

2276

print(mss)

2277

## print(paste(" metadata@shortnames:", paste(x[["shortnames"]], collapse=","), sep=" "))

2278

}

2279

x[["shortnames"]] <- x[["shortnames"]][1:length(names.data)]

2280

shortnames.metadata <- x[["shortnames"]]

2281

if (MY.DEBUG){

2282

print(paste(" will be concatenated:"))

2283

print(as.matrix(shortnames.metadata))

2284

}

2285

} else {

2286

if (length(x[["shortnames"]]) < length(names.data)){

2287

diff <- length(names.data)-length(x[["shortnames"]])

2288

if (MY.DEBUG){

2289

print("metadata@shortnames mismatch length with data column names")

2290

mss <- as.matrix(x[["shortnames"]])

2291

colnames(mss) <- "metadata@shortnames"

2292

print(mss)

2293

## print(paste(" metadata@shortnames:", paste(x[["shortnames"]], collapse=","), sep=" "))

2294

}

2295

x[["shortnames"]] <- c(x[["shortnames"]], rep(NA, diff))

2296

shortnames.metadata <- x[["shortnames"]]

2297

if (MY.DEBUG){

2298

print(paste(" will be changed to:"))

2299

print(as.matrix(shortnames.metadata))

2300

}

2301

}

2302

}

2303

} else {

2304

if (MY.DEBUG){

2305

print(paste("Error Names length mismatch: x@metadata@original Status changed to:",

2306

x[["original"]], sep=" "))

2307

original.stat.check <- FALSE

2308

2309

## what about row.check and col.check?

2310

if (!row.check){

2311

x[["size"]] <- dim.FCS(x)[1]

2312

}

2313

2314

if (!col.check){

2315

x[["nparam"]] <- dim.FCS(x)[2]

2316

}

2317

2318

}

2319

2320

}

2321

2322

2323

}

2324

2325

2326

2327

if (names.check){

2328

long.na <- which(is.na(longnames.metadata))

2329

if (length(long.na)==0){

2330

long.na <- NULL

2331

}

2332

longnames.var <- unlist(strsplit(paste("$P",

2333

1:x[["nparam"]],

2334

"S", sep="",

2335

collapse=","),

2336

split=","))

2337

2338

2339

## note: metadata names are NA if they are missing

2340

short.na <- which(is.na(shortnames.metadata))

2341

if (length(short.na)==0){

2342

short.na <- NULL

2343

}

2344

2345

shortnames.var <- unlist(strsplit(paste("$P",

2346

1:x[["nparam"]],

2347

"N", sep="",

2348

collapse=","),

2349

split=","))

2350

2351

## NOTE: we will change the missing metadata names to "None"

2352

if (!is.null(long.na)){

2353

longnames.metadata[long.na] <- rep("None", length(long.na))

2354

}

2355

2356

if (!is.null(short.na)){

2357

shortnames.metadata[short.na] <- rep("None", length(short.na))

2358

}

2359

2360

## we will change the metadata names to NA if data names are NA

2361

if (!is.null(names.data.na) & length(names.data.na)!=0){

2362

longnames.metadata[names.data.na] <- rep(NA, length(names.data.na))

2363

shortnames.metadata[names.data.na] <- rep(NA, length(names.data.na))

2364

}

2365

2366

## here we check the nonmissing data names

2367

## the data's names that are NOT NA

2368

long.pos.chk <- ifelse(1:length(longnames.metadata) %in% c(names.data.na), 0, 1)

2369

short.pos.chk <- ifelse(1:length(shortnames.metadata) %in% c(names.data.na), 0,1)

2370

long.match <- short.match <- NULL

2371

long.match[long.pos.chk==1] <- ifelse(names.data[long.pos.chk==1]==longnames.metadata[long.pos.chk==1],

2372

1, 0)

2373

long.match[long.pos.chk==0] <- 1 ## the NA's are skipped in the check

2374

short.match[short.pos.chk==1] <- ifelse(names.data[short.pos.chk==1]==shortnames.metadata[short.pos.chk==1],

2375

1, 0)

2376

short.match[short.pos.chk==0] <- 1 ## NA's as skipped in the check

2377

2378

## we will compare against the longnames of the metadata if there

2379

## are more or equal number of matches comparing the data's names with the longnames

2380

## we will compare against the shortnames of the metadata if there

2381

## are more matches of the data's names with the longnames

2382

2383

if (sum(long.match)>=sum(short.match)){

2384

## longnames are used

2385

used.var <- paste(x@metadata@objectname,"@metadata@longnames", sep="")

2386

used.metadata.names <- longnames.var

2387

2388

used.match <- long.match

2389

2390

names.used <- longnames.metadata

2391

o.names.used <- x[["longnames"]]

2392

2393

} else {

2394

## shortnames are used

2395

used.var <- paste( x@metadata@objectname,"@metadata@shortnames", sep="")

2396

used.metadata.names <- shortnames.var

2397

2398

used.match <- short.match

2399

2400

names.used <- shortnames.metadata

2401

o.names.used <- x[["shortnames"]]

2402

2403

}

2404

2405

match.pos.fix <- which(used.match==0)

2406

if (length(match.pos.fix)==0){

2407

match.pos.fix <- NULL

2408

}

2409

2410

names.check <- TRUE

2411

fix.metadata.vars <- NULL

2412

2413

if (is.null(match.pos.fix)==FALSE || length(match.pos.fix) != 0){

2414

names.check <- FALSE

2415

2416

fix.metadata.vars <- used.metadata.names[match.pos.fix]

2417

2418

}

2419

2420

2421

2422

2423

}

2424

2425

if (MY.DEBUG == TRUE) {

2426

print("Names Check:")

2427

names.df.output <- cbind(names.data, o.names.used)

2428

colnames(names.df.output) <- c("Data Parameter Names", used.var)

2429

print(names.df.output)

2430

## print(paste(" ", "Data Parameter Names:", sep=" "))

2431

## for (i in 1:length(names.data)){

2432

## print(paste(" ", names.data[i]))

2433

## }

2434

## print(paste(" ", used.var, ":", sep=" "))

2435

##for (j in 1:length(o.names.used)){

2436

## print(paste(" ", o.names.used[j], sep = " "))

2437

##}

2438

}

2439

2440

2441

if (names.check==FALSE){

2442

2443

## change the metadata to names of the data

2444

slotname <- unlist(strsplit(used.var, split="metadata@"))[2]

2445

2446

idx.vars <- sort(c(which(used.metadata.names %in% fix.metadata.vars), names.data.na), decreasing=FALSE)

2447

x[[slotname]][idx.vars] <- names.data[idx.vars]

2448

2449

if (MY.DEBUG == TRUE) {

2450

## remark that there is a names discrepancy & the fix

2451

2452

print(paste(" ", used.var,"do not match with that of the data.", sep=" "))

2453

print("Names Fix: Replacement of the metadata parameter(s):")

2454

2455

print(as.matrix(used.metadata.names[idx.vars]))

2456

print(" from the old name(s) of the original metadata:")

2457

print(as.matrix(o.names.used[idx.vars]))

2458

print(" to the following name(s) from the data:")

2459

2460

print(as.matrix(names.data[idx.vars]))

2461

}

2462

}

2463

2464

## check: original.stat.check names.check

2465

2466

2467

2468

## C. Fixing the ranges in the metadata

2469

2470

2471

metadata <- x@metadata@fcsinfo

2472

## indicator for the RFACS heading, not used here

2473

2474

is.RFACS.metadata <- unlist(lapply(names(metadata), function(x) {

2475

total.char <- nchar(x)

2476

words <- unlist(strsplit(x, "RFACSadd>>"))

2477

is.RFACS <- NULL

2478

if (nchar(words[1]) < total.char) {

2479

is.RFACS <- TRUE

2480

} else if (nchar(words[1]) == total.char) {

2481

is.RFACS <- FALSE

2482

2483

}

2484

return(is.RFACS)

2485

}))

2486

## obtaining the ranges (max only) of the data

2487

ranges.data.o <- apply(fluors(x), 2, function(x){ max(as.numeric(x))})

2488

ranges.data <- apply(fluors(x), 2, function(x) {

2489

if (!is.null(range.max)){

2490

if (max(as.numeric(x))<range.max){

2491

return(range.max)

2492

} else {

2493

return(max(as.numeric(x)))

2494

}

2495

} else {

2496

return(max(as.numeric(x)))

2497

}

2498

})

2499

2500

## the metadata variables

2501

range.var <- as.vector(paste("$P", 1:(dim.FCS(x)[2]),

2502

"R", sep = ""))

2503

names(ranges.data) <- range.var

2504

2505

## getting the ranges of the metadata

2506

## that are indicated by metadata variable names

2507

## and are not RFACS

2508

2509

## we want to replace the regular $PiR with RFACSadd>>$PiR

2510

2511

2512

ranges.metadata <- x[["$PnR"]]

2513

2514

## if ranges.metadata not the size of ranges.data

2515

if (length(ranges.data) > length(ranges.metadata)){

2516

ranges.check <- FALSE

2517

## force the ranges.metadata to the same length

2518

diff.g <- length(ranges.data)-length(ranges.metadata)

2519

ranges.metadata <- c(ranges.metadata, rep(NA, diff.g))

2520

if (MY.DEBUG){

2521

print("Ranges of the Data is longer than Metadata.")

2522

}

2523

2524

}

2525

2526

if (length(ranges.data) < length(ranges.metadata)){

2527

ranges.check <- FALSE

2528

## force the ranges.metadata to the same length

2529

2530

ranges.metadata <- ranges.metadata[1:length(ranges.data)]

2531

if (MY.DEBUG){

2532

print("Ranges of the Metadata is longer than the Data.")

2533

print(" Only the first corresponding elements of the")

2534

print(" metadata ranges are compared to the data.")

2535

}

2536

}

2537

2538

2539

## making sure the ranges.metadata is numeric

2540

ranges.metadata <- unlist(sapply(ranges.metadata, function(x) {

2541

if (is.null(x)) {

2542

return(NA)

2543

}

2544

else if (is.na(x)) {

2545

return(NA)

2546

}

2547

else {

2548

return(as.numeric(x))

2549

}

2550

}))

2551

## find the missing metadata ranges

2552

missing.pos <- sapply(ranges.metadata, function(x) {

2553

ifelse(is.na(x) || is.null(x), 1, 0)

2554

})

2555

2556

num.missing <- sum(missing.pos, na.rm = TRUE)

2557

2558

if (num.missing > 0) {

2559

for (i in 1:length(range.var[missing.pos==1])){

2560

slotname <- range.var[missing.pos==1][i]

2561

x[[slotname]] <-ranges.data[missing.pos==1][i]

2562

}

2563

if (MY.DEBUG == TRUE) {

2564

print(paste("Range Check: Range parameter(s) missing in the metadata:"))

2565

2566

print(as.matrix(range.var[missing.pos == 1]))

2567

print(paste("Range Fix: Range parameter(s) added to the metadata with range(s):" ))

2568

2569

print(as.matrix(ranges.data[missing.pos==1]))

2570

2571

}

2572

}

2573

2574

ranges.info <- rbind(ranges.data,

2575

ranges.metadata)

2576

ranges.correct <- apply(ranges.info, 2, function(x) {

2577

x <- as.numeric(x)

2578

if (is.element(NA, x)) {

2579

return(0)

2580

} else {

2581

ifelse(x[1] <= x[2], 0, 1)

2582

}

2583

})

2584

ranges.correct <- ifelse(is.na(ranges.correct), 0, ranges.correct)

2585

2586

ranges.check <- sum(ranges.correct)==0

2587

if (ranges.check==FALSE) {

2588

fix.range.var <- range.var[which(ranges.correct==1)]

2589

fix.range.data <- ranges.data[which(ranges.correct==1)]

2590

fix.range.meta <- ranges.metadata[which(ranges.correct==1)]

2591

if (MY.DEBUG==TRUE){

2592

print("Ranges Check: Column parameters are NOT within the ranges specified in the metadata.")

2593

rng.df <- cbind(ranges.data.o, x[["paramranges"]])

2594

colnames(rng.df) <- c("Data Ranges", paste(x[["objectname"]], "@paramranges", sep=""))

2595

print(rng.df)

2596

2597

## print(paste(" Data Ranges:", paste(ranges.data.o, collapse=","), sep=" "))

2598

## print(paste(" ", x[["objectname"]], "@paramranges: ", paste(x[["paramranges"]], collapse=","), sep=""))

2599

print("Range Fix: Replacing the metadata parameter(s):")

2600

print(as.matrix(fix.range.var))

2601

print(" corresponding to the metadata range value(s):")

2602

print(as.matrix(fix.range.meta))

2603

print(" with the following range(s) from the data:")

2604

print(as.matrix(fix.range.data))

2605

}

2606

2607

2608

for (i in 1:length(fix.range.var)){

2609

slotname <- fix.range.var[i]

2610

range.max.i <- fix.range.data[i]

2611

x[[slotname]] <- range.max.i

2612

}

2613

} else if (ranges.check==TRUE){

2614

if (MY.DEBUG == TRUE) {

2615

print("Range Check: Column parameters are within specified metadata range.")

2616

rng.df <- cbind(ranges.data.o,x[["paramranges"]])

2617

colnames(rng.df) <- c("Data Ranges", paste(x[["objectname"]], "@paramranges", sep=""))

2618

print(rng.df)

2619

2620

}

2621

}

2622

2623

2624

## check: ranges.check

2625

## structure(x, class ="FCS")

2626

x

2627

})

2628

2629

2630

setGeneric("equals",

2631

function(x,y,type="FCS", check.filename=FALSE, check.objectname=FALSE) {

2632

standardGeneric("equals")

2633

})

2634

2635

2636

setMethod("equals",

2637

signature(x = "FCS", y="FCS"),

2638

function (x,

2639

y,

2640

type="FCS",

2641

check.filename=FALSE,

2642

check.objectname=FALSE) {

2643

## only checks the equality of two FCS objects

2644

## returns boolean value

2645

if (!is(x, type) || !is(y, type)){

2646

stop("Input 'x' and 'y' should be of class 'FCS'")

2647

}

2648

2649

## metadata match

2650

2651

2652

metadata.match <- TRUE

2653

metadata.x <-x@metadata

2654

metadata.y <- y@metadata

2655

2656

2657

if (!identical(slotNames(metadata.x), slotNames(metadata.y))){

2658

metadata.match <- FALSE

2659

warning("Slot names of the metadata do not match")

2660

} else {

2661

sn <- slotNames(metadata.x)

2662

if (check.filename==FALSE) {

2663

sn <- sn[sn != "filename"]

2664

}

2665

if (check.objectname == FALSE){

2666

sn <- sn[sn!="objectname"]

2667

}

2668

## check all slots:

2669

continue <- TRUE

2670

slotname.pos <- 1

2671

while (continue==TRUE){

2672

2673

metadata.match <- metadata.match & identical(x[[sn[slotname.pos]]],

2674

y[[sn[slotname.pos]]])

2675

2676

slotname.pos <- slotname.pos + 1

2677

continue <- (slotname.pos <= length(sn)) & (metadata.match==TRUE)

2678

}

2679

## checking names of the fcsinfo list

2680

metadata.match <- metadata.match & identical(names(metadata.x@fcsinfo), names(metadata.y@fcsinfo))

2681

}

2682

2683

## data match

2684

data.match <- TRUE

2685

if (metadata.match==TRUE){

2686

data.x <- as(x@data, "matrix")

2687

data.y <- as(y@data, "matrix")

2688

colnam.x <- colnames(data.x)

2689

colnam.y <- colnames(data.y)

2690

2691

data.match <- identical(data.x, data.y) & identical(colnam.x, colnam.y)

2692

2693

}

2694

return(metadata.match & data.match)

2695

2696

})

2697

2698

2699