From 70191600b3eb5ecdc84dcc95c3fa1cbeaf1c4ac0 Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Wed, 27 Dec 2023 00:30:02 +0100 Subject: [PATCH] reformat all code using styler --- DESCRIPTION | 1 + R/bertin.r | 1034 +++++++------ R/calc.r | 1361 ++++++++-------- R/data-openrepgrid.r | 1189 +++++++------- R/dev-functions.r | 463 +++--- R/distance.R | 691 +++++---- R/double-entry.R | 26 +- R/export.r | 430 +++--- R/globals.R | 13 +- R/gmMain.r | 1287 +++++++-------- R/import.r | 1160 +++++++------- R/measures.r | 1788 +++++++++++---------- R/onair.r | 14 +- R/openrepgrid.r | 155 +- R/perturbate.R | 125 +- R/repgrid-basicops.r | 1363 ++++++++-------- R/repgrid-constructs.r | 872 ++++++----- R/repgrid-elements.r | 612 ++++---- R/repgrid-output.r | 1128 +++++++------- R/repgrid-plots.r | 1978 ++++++++++++------------ R/repgrid-ratings.r | 648 ++++---- R/repgrid.r | 166 +- R/resampling.R | 101 +- R/rgl-3d.r | 1347 ++++++++-------- R/settings.r | 376 ++--- R/utils-import.r | 699 +++++---- R/utils.r | 870 ++++++----- R/zzz.r | 23 +- demo/OpenRepGrid.r | 105 +- man/OpenRepGrid-overview.Rd | 2 +- man/addAvgElement.Rd | 3 +- man/addConstruct.Rd | 7 +- man/addElement.Rd | 5 +- man/addIndexColumnToMatrix.Rd | 8 +- man/alignByIdeal.Rd | 8 +- man/alignByLoadings.Rd | 30 +- man/angleOrderIndexes2d.Rd | 10 +- man/apply_pb.Rd | 17 +- man/bertin.Rd | 20 +- man/bertinCluster.Rd | 94 +- man/bind.Rd | 12 +- man/bindConstructs.Rd | 16 +- man/biplot2d.Rd | 82 +- man/biplot3d.Rd | 22 +- man/biplotEsa2d.Rd | 4 +- man/biplotEsa3d.Rd | 15 +- man/biplotEsaPseudo3d.Rd | 4 +- man/biplotPseudo3d.Rd | 38 +- man/biplotSimple.Rd | 22 +- man/biplotSlater2d.Rd | 4 +- man/biplotSlater3d.Rd | 15 +- man/biplotSlaterPseudo3d.Rd | 4 +- man/calcCoordsBorders.Rd | 14 +- man/cascade.Rd | 5 +- man/center.Rd | 8 +- man/clearRatings.Rd | 2 +- man/cluster.Rd | 16 +- man/clusterBoot.Rd | 24 +- man/constructCor.Rd | 32 +- man/constructD.Rd | 23 +- man/constructPca.Rd | 28 +- man/constructPcaLoadings.Rd | 12 +- man/constructRmsCor.Rd | 14 +- man/constructs.Rd | 22 +- man/data-bell2010.Rd | 6 +- man/data-bellmcgorry1992.Rd | 8 +- man/data-slater1977b.Rd | 2 +- man/dim.repgrid.Rd | 3 +- man/distance.Rd | 42 +- man/distanceHartmann.Rd | 46 +- man/distanceNormalized.Rd | 43 +- man/distanceSlater.Rd | 16 +- man/doRectanglesOverlap.Rd | 42 +- man/doubleEntry.Rd | 4 +- man/elementCor.Rd | 32 +- man/elementRmsCor.Rd | 18 +- man/elements.Rd | 8 +- man/extract-methods.Rd | 10 +- man/getConstructNames2.Rd | 9 +- man/getElementNames2.Rd | 9 +- man/getNoOfConstructs.Rd | 2 +- man/getNoOfElements.Rd | 2 +- man/getRatingLayer.Rd | 2 +- man/getScaleMidpoint.Rd | 3 +- man/home.Rd | 11 +- man/importExcel.Rd | 3 +- man/importGridcor.Rd | 2 - man/importGridcorInternal.Rd | 4 +- man/importGridstat.Rd | 2 +- man/importGridstatInternal.Rd | 30 +- man/importGridsuite.Rd | 2 - man/importGridsuiteInternal.Rd | 16 +- man/importScivesco.Rd | 1 - man/importScivescoInternal.Rd | 14 +- man/importTxtInternal.Rd | 1 - man/indexBias.Rd | 4 +- man/indexConflict1.Rd | 6 +- man/indexConflict2.Rd | 28 +- man/indexConflict3.Rd | 32 +- man/indexIntensity.Rd | 30 +- man/indexPvaff.Rd | 2 +- man/indexVariability.Rd | 3 +- man/lapply_pb.Rd | 5 +- man/makeRepgrid.Rd | 24 +- man/map.Rd | 9 +- man/modifyConstruct.Rd | 2 +- man/modifyElement.Rd | 2 +- man/move.Rd | 10 +- man/normalize.Rd | 6 +- man/ops-methods.Rd | 4 +- man/orderByString.Rd | 10 +- man/permuteConstructs.Rd | 5 +- man/permuteGrid.Rd | 13 +- man/prepareBiplotData.Rd | 4 +- man/quasiDistributionDistanceSlater.Rd | 11 +- man/randomGrid.Rd | 12 +- man/randomGrids.Rd | 12 +- man/randomSentence.Rd | 3 +- man/randomSentences.Rd | 4 +- man/randomWords.Rd | 2 +- man/ratings.Rd | 18 +- man/recycle.Rd | 12 +- man/recycle2.Rd | 4 +- man/reorder.Rd | 2 +- man/reorder2d.Rd | 8 +- man/reverse.Rd | 8 +- man/ring.Rd | 9 +- man/sapply_pb.Rd | 13 +- man/saveAsExcel.Rd | 5 +- man/saveAsTxt.Rd | 5 +- man/setConstructAttr.Rd | 8 +- man/setElementAttr.Rd | 8 +- man/setMeta.Rd | 2 +- man/setScale.Rd | 10 +- man/settings.Rd | 6 +- man/shift.Rd | 8 +- man/showMeta.Rd | 2 +- man/showScale.Rd | 4 +- man/ssq.Rd | 34 +- man/stats.Rd | 30 +- man/stepChart.Rd | 8 +- man/subassign.Rd | 16 +- man/swapConstructs.Rd | 6 +- man/swapElements.Rd | 6 +- man/trim_val.Rd | 2 +- tests/testthat/test-basicops.R | 32 +- tests/testthat/test-gridlist.R | 29 +- tests/testthat/test-indexes.R | 61 +- tests/testthat/test_bertin.R | 4 +- tests/testthat/test_biplot.R | 6 +- 150 files changed, 11223 insertions(+), 10446 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 931cd02b..9edce3eb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -75,5 +75,6 @@ NeedsCompilation: no Suggests: testthat (>= 2.1.0), covr, + styler, vdiffr Roxygen: list(markdown = TRUE) diff --git a/R/bertin.r b/R/bertin.r index 4b2d5235..7a182ea0 100644 --- a/R/bertin.r +++ b/R/bertin.r @@ -1,201 +1,214 @@ - -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # -# BERTIN DISPLAYS a.k.a. HEATMAPS +# BERTIN DISPLAYS a.k.a. HEATMAPS # -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// -constructCellGrob <- function(text, gp=gpar(), horiz=TRUE){ - gp <- modifyList(gpar(fill=grey(.95)), gp) - col <- gmSelectTextColorByLuminance(gp$fill) - gTree(children=gList( rectGrob(width=1, height=1, - gp=gpar(fill=gp$fill, col="white")), - gmSplitTextGrob(text=text, horiz=horiz, gp=modifyList(gp, gpar(col=col))) - )) +constructCellGrob <- function(text, gp = gpar(), horiz = TRUE) { + gp <- modifyList(gpar(fill = grey(.95)), gp) + col <- gmSelectTextColorByLuminance(gp$fill) + gTree(children = gList( + rectGrob( + width = 1, height = 1, + gp = gpar(fill = gp$fill, col = "white") + ), + gmSplitTextGrob(text = text, horiz = horiz, gp = modifyList(gp, gpar(col = col))) + )) } -bertin1 <- function(x, draw=TRUE){ - if(!inherits(x, "repgrid")) - stop("Object must be of class 'repgrid'") - +bertin1 <- function(x, draw = TRUE) { + if (!inherits(x, "repgrid")) { + stop("Object must be of class 'repgrid'") + } + # determine color range (shades of grey) nrow <- nrow(x@ratings) ncol <- ncol(x@ratings) - + # settings - height.element.label <- 5 - height.cell <- unit(3, "mm") - height.fg.top <- unit(ncol * height.element.label, "mm") - - - bertinCell <- function(label, fill){ - textColor <- gmSelectTextColorByLuminance(fill) - gTree(children=gList( - rectGrob(width=1, height=1, - gp=gpar(fill=fill, col="white")), - textGrob(label=label, gp=gpar(lineheight=.7, cex=.6, col=textColor)) - )) - } - - # rating framegrob - dp.fg <- frameGrob(grid.layout(nrow=nrow, ncol=ncol, respect=F)) - scale.range <- x@scale$max - x@scale$min - for (row in seq_len(nrow)){ - for (col in seq_len(ncol)){ - score <- x@ratings[row, col, 1] - rg <- bertinCell(label=score, fill=grey((score - x@scale$min) / scale.range)) - dp.fg <- placeGrob(dp.fg , rg, row = row, col = col) - } - } - - # left framegrob (initial pole) - left.c.fg <- frameGrob(grid.layout(nrow=nrow, ncol=1)) - for(row in seq_len(nrow)){ - label <- x@constructs[[row]]$leftpole$name - tg <- textGrob(label=label, gp=gpar(cex=.6)) - left.c.fg <- placeGrob(left.c.fg, tg, row=row) - } - - # top framegrob (elements) - top.e.fg <- frameGrob(grid.layout(ncol=ncol, nrow=ncol + 1, respect=F)) - rg <- rectGrob( gp=gpar(fill="black", col="white"), - vp=viewport(width=unit(1, "points"))) - for(row in seq_len(ncol)){ - label <- x@elements[[row]]$name - tg <- textGrob(label=label, x=.4, just="left", gp=gpar(cex=.6)) - top.e.fg <- placeGrob(top.e.fg, tg, row=row, col=row) - top.e.fg <- placeGrob(top.e.fg, rg, row=row:ncol + 1, col=row) - } - - # combine framegrobs - main.fg <- frameGrob(grid.layout(nrow=4, ncol=3, heights=c(.1, 2 ,2,.2), widths=c(1,2,1))) - main.fg <- placeGrob(main.fg, top.e.fg, row= 2, col = 2) - main.fg <- placeGrob(main.fg, left.c.fg, row= 3, col = 1) - main.fg <- placeGrob(main.fg, dp.fg, row= 3, col = 2) - main.fg <- placeGrob(main.fg, left.c.fg, row=3, col = 3) - if(draw) grid.draw(main.fg) else main.fg + height.element.label <- 5 + height.cell <- unit(3, "mm") + height.fg.top <- unit(ncol * height.element.label, "mm") + + + bertinCell <- function(label, fill) { + textColor <- gmSelectTextColorByLuminance(fill) + gTree(children = gList( + rectGrob( + width = 1, height = 1, + gp = gpar(fill = fill, col = "white") + ), + textGrob(label = label, gp = gpar(lineheight = .7, cex = .6, col = textColor)) + )) + } + + # rating framegrob + dp.fg <- frameGrob(grid.layout(nrow = nrow, ncol = ncol, respect = F)) + scale.range <- x@scale$max - x@scale$min + for (row in seq_len(nrow)) { + for (col in seq_len(ncol)) { + score <- x@ratings[row, col, 1] + rg <- bertinCell(label = score, fill = grey((score - x@scale$min) / scale.range)) + dp.fg <- placeGrob(dp.fg, rg, row = row, col = col) + } + } + + # left framegrob (initial pole) + left.c.fg <- frameGrob(grid.layout(nrow = nrow, ncol = 1)) + for (row in seq_len(nrow)) { + label <- x@constructs[[row]]$leftpole$name + tg <- textGrob(label = label, gp = gpar(cex = .6)) + left.c.fg <- placeGrob(left.c.fg, tg, row = row) + } + + # top framegrob (elements) + top.e.fg <- frameGrob(grid.layout(ncol = ncol, nrow = ncol + 1, respect = F)) + rg <- rectGrob( + gp = gpar(fill = "black", col = "white"), + vp = viewport(width = unit(1, "points")) + ) + for (row in seq_len(ncol)) { + label <- x@elements[[row]]$name + tg <- textGrob(label = label, x = .4, just = "left", gp = gpar(cex = .6)) + top.e.fg <- placeGrob(top.e.fg, tg, row = row, col = row) + top.e.fg <- placeGrob(top.e.fg, rg, row = row:ncol + 1, col = row) + } + + # combine framegrobs + main.fg <- frameGrob(grid.layout(nrow = 4, ncol = 3, heights = c(.1, 2, 2, .2), widths = c(1, 2, 1))) + main.fg <- placeGrob(main.fg, top.e.fg, row = 2, col = 2) + main.fg <- placeGrob(main.fg, left.c.fg, row = 3, col = 1) + main.fg <- placeGrob(main.fg, dp.fg, row = 3, col = 2) + main.fg <- placeGrob(main.fg, left.c.fg, row = 3, col = 3) + if (draw) grid.draw(main.fg) else main.fg } -bertin2 <- function(x, ratings=TRUE, top=unit(40, "mm"), sides=unit(40, "mm") , - left=sides, right=sides, - cell=unit(6, "mm"), cell.height=cell, cell.width=cell, - gp.cells=gpar(), gp.constructs=gpar(), gp.elements=gpar(), - bg.col=grey(.95), colors=c("white", "black"), draw=TRUE){ - if(!inherits(x, "repgrid")) - stop("Object must be of class 'repgrid'") - - gp.cells <- modifyList(gpar(lineheight=.7, cex=.6, fill=bg.col), gp.cells) - gp.constructs <- modifyList(gpar(lineheight=.7, cex=.8, fill=bg.col), gp.constructs) - gp.elements <- modifyList(gpar(lineheight=.7, cex=.8, fill=bg.col), gp.elements) - - # determine color range (shades of grey) - nrow <- nrow(x@ratings) - ncol <- ncol(x@ratings) - - height.top <- top - width.left <- left - width.right <- right - height.cell <- cell.height - width.cell <- cell.width - height.body <- nrow * height.cell - width.body <- ncol * width.cell - - bertinCell <- function(label, fill, gp=gpar(), ratings=TRUE){ - textColor <- gmSelectTextColorByLuminance(fill) - gp <- modifyList(gp, gpar(col=textColor)) - if(ratings) tg <- textGrob(label=label, gp=gp) else tg <- nullGrob() - gTree(children=gList( - rectGrob(width=1, height=1, - gp=gpar(fill=fill, col="white")), - tg - )) - } - - # rating framegrob - colorFun <- makeStandardRangeColorRamp(colors) - dp.fg <- frameGrob(grid.layout(nrow=nrow, ncol=ncol, respect=F)) - scale.range <- x@scale$max - x@scale$min - scale.min <- x@scale$min - for (row in seq_len(nrow)){ - for (col in seq_len(ncol)){ - score <- x@ratings[row, col, 1] - rg <- bertinCell(label=score, fill=colorFun((score-scale.min)/scale.range), gp=gp.cells, ratings=ratings) - dp.fg <- placeGrob(dp.fg , rg, row = row, col = col) - } - } - - # left framegrob (initial pole) - left.c.fg <- frameGrob(grid.layout(nrow=nrow, ncol=1)) - for(row in seq_len(nrow)){ - text <- x@constructs[[row]]$leftpole$name - tg <- constructCellGrob(text=text, gp=gp.constructs) - left.c.fg <- placeGrob(left.c.fg, tg, row=row) - } - - # right framegrob (contrast pole) - right.c.fg <- frameGrob(grid.layout(nrow=nrow, ncol=1)) - for(row in seq_len(nrow)){ - text <- x@constructs[[row]]$rightpole$name - tg <- constructCellGrob(text=text, gp=gp.constructs) - right.c.fg <- placeGrob(right.c.fg, tg, row=row) - } - - # top framegrob (elements) - top.e.fg <- frameGrob(grid.layout(ncol=ncol, nrow=1)) - for(col in seq_len(ncol)){ - text <- x@elements[[col]]$name - tg <- constructCellGrob(text=text, horiz=FALSE, gp=gp.elements) - top.e.fg <- placeGrob(top.e.fg, tg, row=NULL, col=col) - } - - # combine framegrobs - main.fg <- frameGrob(grid.layout(nrow=2, ncol=3, heights=unit.c(height.top, height.body), widths=unit.c(width.left, width.body, width.right))) - main.fg <- placeGrob(main.fg, top.e.fg, row= 1, col = 2) - main.fg <- placeGrob(main.fg, left.c.fg, row= 2, col = 1) - main.fg <- placeGrob(main.fg, dp.fg, row= 2, col = 2) - main.fg <- placeGrob(main.fg, right.c.fg, row=2, col = 3) - if(draw) grid.draw(main.fg) else main.fg +bertin2 <- function(x, ratings = TRUE, top = unit(40, "mm"), sides = unit(40, "mm"), + left = sides, right = sides, + cell = unit(6, "mm"), cell.height = cell, cell.width = cell, + gp.cells = gpar(), gp.constructs = gpar(), gp.elements = gpar(), + bg.col = grey(.95), colors = c("white", "black"), draw = TRUE) { + if (!inherits(x, "repgrid")) { + stop("Object must be of class 'repgrid'") + } + + gp.cells <- modifyList(gpar(lineheight = .7, cex = .6, fill = bg.col), gp.cells) + gp.constructs <- modifyList(gpar(lineheight = .7, cex = .8, fill = bg.col), gp.constructs) + gp.elements <- modifyList(gpar(lineheight = .7, cex = .8, fill = bg.col), gp.elements) + + # determine color range (shades of grey) + nrow <- nrow(x@ratings) + ncol <- ncol(x@ratings) + + height.top <- top + width.left <- left + width.right <- right + height.cell <- cell.height + width.cell <- cell.width + height.body <- nrow * height.cell + width.body <- ncol * width.cell + + bertinCell <- function(label, fill, gp = gpar(), ratings = TRUE) { + textColor <- gmSelectTextColorByLuminance(fill) + gp <- modifyList(gp, gpar(col = textColor)) + if (ratings) tg <- textGrob(label = label, gp = gp) else tg <- nullGrob() + gTree(children = gList( + rectGrob( + width = 1, height = 1, + gp = gpar(fill = fill, col = "white") + ), + tg + )) + } + + # rating framegrob + colorFun <- makeStandardRangeColorRamp(colors) + dp.fg <- frameGrob(grid.layout(nrow = nrow, ncol = ncol, respect = F)) + scale.range <- x@scale$max - x@scale$min + scale.min <- x@scale$min + for (row in seq_len(nrow)) { + for (col in seq_len(ncol)) { + score <- x@ratings[row, col, 1] + rg <- bertinCell(label = score, fill = colorFun((score - scale.min) / scale.range), gp = gp.cells, ratings = ratings) + dp.fg <- placeGrob(dp.fg, rg, row = row, col = col) + } + } + + # left framegrob (initial pole) + left.c.fg <- frameGrob(grid.layout(nrow = nrow, ncol = 1)) + for (row in seq_len(nrow)) { + text <- x@constructs[[row]]$leftpole$name + tg <- constructCellGrob(text = text, gp = gp.constructs) + left.c.fg <- placeGrob(left.c.fg, tg, row = row) + } + + # right framegrob (contrast pole) + right.c.fg <- frameGrob(grid.layout(nrow = nrow, ncol = 1)) + for (row in seq_len(nrow)) { + text <- x@constructs[[row]]$rightpole$name + tg <- constructCellGrob(text = text, gp = gp.constructs) + right.c.fg <- placeGrob(right.c.fg, tg, row = row) + } + + # top framegrob (elements) + top.e.fg <- frameGrob(grid.layout(ncol = ncol, nrow = 1)) + for (col in seq_len(ncol)) { + text <- x@elements[[col]]$name + tg <- constructCellGrob(text = text, horiz = FALSE, gp = gp.elements) + top.e.fg <- placeGrob(top.e.fg, tg, row = NULL, col = col) + } + + # combine framegrobs + main.fg <- frameGrob(grid.layout(nrow = 2, ncol = 3, heights = unit.c(height.top, height.body), widths = unit.c(width.left, width.body, width.right))) + main.fg <- placeGrob(main.fg, top.e.fg, row = 1, col = 2) + main.fg <- placeGrob(main.fg, left.c.fg, row = 2, col = 1) + main.fg <- placeGrob(main.fg, dp.fg, row = 2, col = 2) + main.fg <- placeGrob(main.fg, right.c.fg, row = 2, col = 3) + if (draw) grid.draw(main.fg) else main.fg } -bertin2PlusLegend <- function(x, ratings=TRUE, top=unit(40, "mm"), - sides=unit(40, "mm"), left=sides, right=sides, - cell=unit(6, "mm"), cell.height=cell, cell.width=cell, - gp.cells=gpar(), gp.constructs=gpar(), gp.elements=gpar(), - bg.col=grey(.95), colors=c("white", "black"), draw=TRUE, - vspace=unit(2,"mm"), legend.just="left", legend.height=unit(10, "mm"), - legend.width=unit(40, "mm")) -{ - fg.bertin <- bertin2( x=x, ratings=ratings, top=top, - sides=sides, left=left, right=right, - cell=cell, cell.height=cell.height, cell.width=cell.width, - gp.cells=gp.cells, gp.constructs=gp.constructs, gp.elements=gp.elements, - bg.col=bg.col, colors=colors, draw=FALSE) - - widths <- fg.bertin$framevp$layout$widths - heights <- fg.bertin$framevp$layout$heights - nrow <- fg.bertin$framevp$layout$nrow - ncol <- fg.bertin$framevp$layout$ncol - - colorFun <- makeStandardRangeColorRamp(colors) - lg <- gmLegend2(colorFun(c(0,1)), c("left pole", "right pole"), ncol=2, byrow=F) - fg.legend <- frameGrob(grid.layout(widths=legend.width, just=legend.just)) - fg.legend <- placeGrob(fg.legend, lg) - fg.main <- frameGrob(grid.layout(nrow=nrow + 2, heights=unit.c(heights, vspace, legend.height), - ncol=ncol, widths=widths)) - fg.main <- placeGrob(fg.main, fg.bertin, row=1:nrow) - fg.main <- placeGrob(fg.main, fg.legend , row=nrow + 2) - - if(draw) grid.draw(fg.main) else fg.main +bertin2PlusLegend <- function(x, ratings = TRUE, top = unit(40, "mm"), + sides = unit(40, "mm"), left = sides, right = sides, + cell = unit(6, "mm"), cell.height = cell, cell.width = cell, + gp.cells = gpar(), gp.constructs = gpar(), gp.elements = gpar(), + bg.col = grey(.95), colors = c("white", "black"), draw = TRUE, + vspace = unit(2, "mm"), legend.just = "left", legend.height = unit(10, "mm"), + legend.width = unit(40, "mm")) { + fg.bertin <- bertin2( + x = x, ratings = ratings, top = top, + sides = sides, left = left, right = right, + cell = cell, cell.height = cell.height, cell.width = cell.width, + gp.cells = gp.cells, gp.constructs = gp.constructs, gp.elements = gp.elements, + bg.col = bg.col, colors = colors, draw = FALSE + ) + + widths <- fg.bertin$framevp$layout$widths + heights <- fg.bertin$framevp$layout$heights + nrow <- fg.bertin$framevp$layout$nrow + ncol <- fg.bertin$framevp$layout$ncol + + colorFun <- makeStandardRangeColorRamp(colors) + lg <- gmLegend2(colorFun(c(0, 1)), c("left pole", "right pole"), ncol = 2, byrow = F) + fg.legend <- frameGrob(grid.layout(widths = legend.width, just = legend.just)) + fg.legend <- placeGrob(fg.legend, lg) + fg.main <- frameGrob(grid.layout( + nrow = nrow + 2, heights = unit.c(heights, vspace, legend.height), + ncol = ncol, widths = widths + )) + fg.main <- placeGrob(fg.main, fg.bertin, row = 1:nrow) + fg.main <- placeGrob(fg.main, fg.legend, row = nrow + 2) + + if (draw) grid.draw(fg.main) else fg.main } # bertin2PlusLegend(rg2, colors=c("darkred", "white")) @@ -204,252 +217,275 @@ bertin2PlusLegend <- function(x, ratings=TRUE, top=unit(40, "mm"), -# TODO: -may work with closures here to store old row and column when marking +# TODO: -may work with closures here to store old row and column when marking # rows and columns? # -splitString has a bug, breaks too late # -trimming of elements and constructs # -#' Workhorse for the biplot printing. +#' Workhorse for the biplot printing. #' -#' Prints a bertin to the output -#' device. It uses the R base graphics system and +#' Prints a bertin to the output +#' device. It uses the R base graphics system and #' this is very fast. This is useful for working with grids. Not so much for #' producing high-quality output. #' -#' @param x `repgrid` object. +#' @param x `repgrid` object. #' @param ratings Vector. rating scores are printed in the cells -#' @param margins Vector of length three (default `margins=c(0,1,1)`). -#' 1st element denotes the left, 2nd the upper and 3rd the +#' @param margins Vector of length three (default `margins=c(0,1,1)`). +#' 1st element denotes the left, 2nd the upper and 3rd the #' right margin in npc coordinates (i.e. 0 to zero). #' @param trim Vector (default `trim=c(F,F)`).If a number the string -#' is trimmed to the given number of characters. If set +#' is trimmed to the given number of characters. If set #' to TRUE the labels are trimmed to the available space -#' @param add Logical. Whether to add bertin to existent plot (default is +#' @param add Logical. Whether to add bertin to existent plot (default is #' `FALSE`). If `TRUE, plot.new()` will not be called #' `par(new=TRUE)`. #' @return `NULL` just for printing. #' #' @export #' @keywords internal -#' -bertinBase <- function(nrow, ncol, labels="", labels.elements="", - labels.left="", labels.right="", - col.text=NA, cex.text=.6, cex.elements=.7, - cex.constructs=.7, col.fill=grey(.8), border="white", - xlim=c(0,1), ylim=c(0,1), margins=c(0,1,1), lheight=.75, - text.margin=0.005, elements.offset=c(0.002, 0.002), - id=c(T,T), cc=0, cr=0, cc.old=0, cr.old=0, - col.mark.fill="#FCF5A4", print=TRUE, byrow=FALSE, add=FALSE) -{ - if (byrow) - labels <- as.vector(matrix(labels, nrow=nrow, ncol=ncol, byrow=TRUE)) - col.fill <- recycle(col.fill, nrow*ncol) # recycle col.fill if too short e.g. one color - if (identical(col.text, NA)) # if not explicitly defined replace col.text according to bg color +#' +bertinBase <- function(nrow, ncol, labels = "", labels.elements = "", + labels.left = "", labels.right = "", + col.text = NA, cex.text = .6, cex.elements = .7, + cex.constructs = .7, col.fill = grey(.8), border = "white", + xlim = c(0, 1), ylim = c(0, 1), margins = c(0, 1, 1), lheight = .75, + text.margin = 0.005, elements.offset = c(0.002, 0.002), + id = c(T, T), cc = 0, cr = 0, cc.old = 0, cr.old = 0, + col.mark.fill = "#FCF5A4", print = TRUE, byrow = FALSE, add = FALSE) { + if (byrow) { + labels <- as.vector(matrix(labels, nrow = nrow, ncol = ncol, byrow = TRUE)) + } + col.fill <- recycle(col.fill, nrow * ncol) # recycle col.fill if too short e.g. one color + if (identical(col.text, NA)) { # if not explicitly defined replace col.text according to bg color col.text <- gmSelectTextColorByLuminance(col.fill) - else recycle(col.text, nrow*ncol) - #if (length(trim) == 1) # if only one parameter given, extend to the other + } else { + recycle(col.text, nrow * ncol) + } + # if (length(trim) == 1) # if only one parameter given, extend to the other # trim <- recycle(trim, 2) - if (length(id) == 1) - id <- recycle(id, 2) + if (length(id) == 1) { + id <- recycle(id, 2) + } - makeMain <- function(){ + makeMain <- function() { rect(x1, y1, x2, y2, col = col.fill, border = border) - text(x1 + cell.width/2, y1 + cell.height/2, labels=labels, col=col.text, cex=cex.text) - } - - makeElements <- function(){ #### elements - index <- cascade(ncol, type=2) - if (id[2]){ - labels.elements[index$left] <- paste(labels.elements[index$left], - "-", index$left) - labels.elements[index$right] <- paste(index$right, "-", - labels.elements[index$right]) + text(x1 + cell.width / 2, y1 + cell.height / 2, labels = labels, col = col.text, cex = cex.text) + } + + makeElements <- function() { #### elements + index <- cascade(ncol, type = 2) + if (id[2]) { + labels.elements[index$left] <- paste( + labels.elements[index$left], + "-", index$left + ) + labels.elements[index$right] <- paste( + index$right, "-", + labels.elements[index$right] + ) } height.strokes <- (margins[2] - ylim[2]) / (max(cascade(ncol) + 1)) x.lines <- xlim[1] + x1.o * diff(xlim) + cell.width / 2 y1.lines <- ylim[2] - y2.lines <- y1.lines + cascade(ncol) * height.strokes # upper end of bertin main plus offset + y2.lines <- y1.lines + cascade(ncol) * height.strokes # upper end of bertin main plus offset segments(x.lines, y1.lines, x.lines, y2.lines) - text(x.lines[index$left] + elements.offset[1], - y2.lines[index$left] + elements.offset[2], - labels=labels.elements[index$left], adj=c(1,0), cex=cex.elements, xpd=T) - text(x.lines[index$right] - elements.offset[1], - y2.lines[index$right] + elements.offset[2], - labels=labels.elements[index$right], adj=c(0,0), cex=cex.elements, xpd=T) - } - - makeConstructs <- function(){ ### constructs - if (id[1]){ - labels.left <- paste(labels.left, " (", 1:nrow, ")", sep="") - labels.right <- paste("(", 1:nrow, ") ", labels.right, sep="") - } - labels.left <- baseSplitString(labels.left, availwidth= (xlim[1] - margins[1])* .95, cex=cex.text) - labels.right <- baseSplitString(labels.right, availwidth=(margins[3] - xlim[2]) * .95, cex=cex.text) - par(lheight=lheight) # set lineheight - text(xlim[1] - text.margin, y1[1:nrow] + cell.height/2, labels=labels.left, - cex=cex.constructs, adj=1, xpd=T) - text(xlim[2] + text.margin, y1[1:nrow] + cell.height/2, labels=labels.right, - cex=cex.constructs, adj=0, xpd=T) - } - - colorRow <- function(cr){ - par(new=TRUE) # next plot will overplot not earse the old one, necessary for setting the same regions + text(x.lines[index$left] + elements.offset[1], + y2.lines[index$left] + elements.offset[2], + labels = labels.elements[index$left], adj = c(1, 0), cex = cex.elements, xpd = T + ) + text(x.lines[index$right] - elements.offset[1], + y2.lines[index$right] + elements.offset[2], + labels = labels.elements[index$right], adj = c(0, 0), cex = cex.elements, xpd = T + ) + } + + makeConstructs <- function() { ### constructs + if (id[1]) { + labels.left <- paste(labels.left, " (", 1:nrow, ")", sep = "") + labels.right <- paste("(", 1:nrow, ") ", labels.right, sep = "") + } + labels.left <- baseSplitString(labels.left, availwidth = (xlim[1] - margins[1]) * .95, cex = cex.text) + labels.right <- baseSplitString(labels.right, availwidth = (margins[3] - xlim[2]) * .95, cex = cex.text) + par(lheight = lheight) # set lineheight + text(xlim[1] - text.margin, y1[1:nrow] + cell.height / 2, + labels = labels.left, + cex = cex.constructs, adj = 1, xpd = T + ) + text(xlim[2] + text.margin, y1[1:nrow] + cell.height / 2, + labels = labels.right, + cex = cex.constructs, adj = 0, xpd = T + ) + } + + colorRow <- function(cr) { + par(new = TRUE) # next plot will overplot not earse the old one, necessary for setting the same regions plot.new() - #plot.window(xlim=0:1, ylim=0:1) #, xaxs="i", yaxs="i")#, asp =nrow/ncol) - if (cr >= 1 & cr <= nrow){ # color current row cr - labels.rows <- labels[(1:ncol-1)*nrow + cr] - col.mark.text=gmSelectTextColorByLuminance(col.mark.fill) - rect(x1.rc, y1.rc[cr], x2.rc, y2.rc[cr], - col = col.mark.fill, border = border) - text(x1.rc + cell.width/2, y1.rc[cr] + cell.height/2, - labels=labels.rows, col=col.mark.text, cex=cex.text) + # plot.window(xlim=0:1, ylim=0:1) #, xaxs="i", yaxs="i")#, asp =nrow/ncol) + if (cr >= 1 & cr <= nrow) { # color current row cr + labels.rows <- labels[(1:ncol - 1) * nrow + cr] + col.mark.text <- gmSelectTextColorByLuminance(col.mark.fill) + rect(x1.rc, y1.rc[cr], x2.rc, y2.rc[cr], + col = col.mark.fill, border = border + ) + text(x1.rc + cell.width / 2, y1.rc[cr] + cell.height / 2, + labels = labels.rows, col = col.mark.text, cex = cex.text + ) } } - - colorColumn <- function(cc){ - par(new=TRUE) # next plot will overplot not earse the old one, necessary for setting the same regions + + colorColumn <- function(cc) { + par(new = TRUE) # next plot will overplot not earse the old one, necessary for setting the same regions plot.new() - #plot.window(xlim=0:1, ylim=0:1) #, xaxs="i", yaxs="i")#, asp =nrow/ncol) - if (cc >= 1 & cc <= ncol){ # color current column cc - labels.cols <- labels[1:nrow + (cc-1)*nrow] - #col.fill <- col.fill[1:nrow + (cc-1)*nrow] - #col.text=gmSelectTextColorByLuminance(col.fill) - col.mark.text=gmSelectTextColorByLuminance(col.mark.fill) - rect(x1.rc[cc], y1.rc, x2.rc[cc], y2.rc, - col = col.mark.fill, border = border) - text(x1.rc[cc] + cell.width/2, y1.rc + cell.height/2, - labels=labels.cols, col=col.mark.text, cex=cex.text) + # plot.window(xlim=0:1, ylim=0:1) #, xaxs="i", yaxs="i")#, asp =nrow/ncol) + if (cc >= 1 & cc <= ncol) { # color current column cc + labels.cols <- labels[1:nrow + (cc - 1) * nrow] + # col.fill <- col.fill[1:nrow + (cc-1)*nrow] + # col.text=gmSelectTextColorByLuminance(col.fill) + col.mark.text <- gmSelectTextColorByLuminance(col.mark.fill) + rect(x1.rc[cc], y1.rc, x2.rc[cc], y2.rc, + col = col.mark.fill, border = border + ) + text(x1.rc[cc] + cell.width / 2, y1.rc + cell.height / 2, + labels = labels.cols, col = col.mark.text, cex = cex.text + ) # color vertical stroke height.strokes <- (1 - ylim[2]) / (max(cascade(ncol) + 1)) x.lines <- xlim[1] + x1.o * diff(xlim) + cell.width / 2 y1.lines <- ylim[2] - y2.lines <- y1.lines + cascade(ncol) * height.strokes - segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], lwd=3, col="white") # overplot old stroke in white - segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], col=col.mark.fill) + y2.lines <- y1.lines + cascade(ncol) * height.strokes + segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], lwd = 3, col = "white") # overplot old stroke in white + segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], col = col.mark.fill) } } - - renewColumn <- function(cc){ - if (cc >= 1 & cc <= ncol){ + + renewColumn <- function(cc) { + if (cc >= 1 & cc <= ncol) { # vertical stroke height.strokes <- (1 - ylim[2]) / (max(cascade(ncol) + 1)) x.lines <- xlim[1] + x1.o * diff(xlim) + cell.width / 2 y1.lines <- ylim[2] - y2.lines <- y1.lines + cascade(ncol) * height.strokes - segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], lwd=3, col="white") # overplot old stroke in white - segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], col="black") - + y2.lines <- y1.lines + cascade(ncol) * height.strokes + segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], lwd = 3, col = "white") # overplot old stroke in white + segments(x.lines[cc], y1.lines, x.lines[cc], y2.lines[cc], col = "black") + # plot rects and text - labels.cols <- labels[1:nrow + (cc-1)*nrow] - col.fill <- col.fill[1:nrow + (cc-1)*nrow] - col.text=gmSelectTextColorByLuminance(col.fill) - rect(x1.rc[cc], y1.rc, x2.rc[cc], y2.rc, - col = col.fill, border = border) - text(x1.rc[cc] + cell.width/2, y1.rc + cell.height/2, - labels=labels.cols, col=col.text, cex=cex.text) + labels.cols <- labels[1:nrow + (cc - 1) * nrow] + col.fill <- col.fill[1:nrow + (cc - 1) * nrow] + col.text <- gmSelectTextColorByLuminance(col.fill) + rect(x1.rc[cc], y1.rc, x2.rc[cc], y2.rc, + col = col.fill, border = border + ) + text(x1.rc[cc] + cell.width / 2, y1.rc + cell.height / 2, + labels = labels.cols, col = col.text, cex = cex.text + ) } } - - renewRow <- function(cr){ - if (cr >= 1 & cr <= nrow){ + + renewRow <- function(cr) { + if (cr >= 1 & cr <= nrow) { # plot rects and text - labels.rows <- labels[(1:ncol-1)*nrow + cr] - col.fill <- col.fill[(1:ncol-1)*nrow + cr] - col.text=gmSelectTextColorByLuminance(col.fill) - rect(x1.rc, y1.rc[cr], x2.rc, y2.rc[cr], - col = col.fill, border = border) - text(x1.rc + cell.width/2, y1.rc[cr] + cell.height/2, - labels=labels.rows, col=col.text, cex=cex.text) + labels.rows <- labels[(1:ncol - 1) * nrow + cr] + col.fill <- col.fill[(1:ncol - 1) * nrow + cr] + col.text <- gmSelectTextColorByLuminance(col.fill) + rect(x1.rc, y1.rc[cr], x2.rc, y2.rc[cr], + col = col.fill, border = border + ) + text(x1.rc + cell.width / 2, y1.rc[cr] + cell.height / 2, + labels = labels.rows, col = col.text, cex = cex.text + ) } } - + # make basic calculations - x1.o <- 0:(ncol - 1)/ncol - x2.o <- 1:ncol/ncol - y1.o <- rev(0:(nrow - 1)/nrow) - y2.o <- rev(1:nrow/nrow) - - x1 <- rep(x1.o, each=nrow) - x2 <- rep(x2.o, each=nrow) + x1.o <- 0:(ncol - 1) / ncol + x2.o <- 1:ncol / ncol + y1.o <- rev(0:(nrow - 1) / nrow) + y2.o <- rev(1:nrow / nrow) + + x1 <- rep(x1.o, each = nrow) + x2 <- rep(x2.o, each = nrow) y1 <- rep(y1.o, ncol) y2 <- rep(y2.o, ncol) - x1 <- xlim[1] + x1 * diff(xlim) # rescale coordinates according to given limits - x2 <- xlim[1] + x2 * diff(xlim) + x1 <- xlim[1] + x1 * diff(xlim) # rescale coordinates according to given limits + x2 <- xlim[1] + x2 * diff(xlim) y1 <- ylim[1] + y1 * diff(ylim) y2 <- ylim[1] + y2 * diff(ylim) - + cell.width <- diff(xlim) / ncol cell.height <- diff(ylim) / nrow - - x1.rc <- x1[(1:ncol)*nrow] # calc coords for row and col starts and ends - x2.rc <- x2[(1:ncol)*nrow] + + x1.rc <- x1[(1:ncol) * nrow] # calc coords for row and col starts and ends + x2.rc <- x2[(1:ncol) * nrow] y1.rc <- y1[1:nrow] y2.rc <- y2[(1:nrow)] - + # set plotting parameters - #old.par <- par(no.readonly = TRUE) # save parameters - #on.exit(par(old.par)) # reset old par when done - op <- par(oma=rep(0,4), mar=rep(0,4), xaxs="i", yaxs="i") - if (print) # in case no new printing should occur - par(new=FALSE) - else - par(new=TRUE) - if (add) # will bertin be added to existent plot? - par(new=TRUE) - + # old.par <- par(no.readonly = TRUE) # save parameters + # on.exit(par(old.par)) # reset old par when done + op <- par(oma = rep(0, 4), mar = rep(0, 4), xaxs = "i", yaxs = "i") + if (print) { # in case no new printing should occur + par(new = FALSE) + } else { + par(new = TRUE) + } + if (add) { # will bertin be added to existent plot? + par(new = TRUE) + } + plot.new() - #plot.window(xlim=0:1, ylim=0:1) #, xaxs="i", yaxs="i")#, asp =nrow/ncol) - + # plot.window(xlim=0:1, ylim=0:1) #, xaxs="i", yaxs="i")#, asp =nrow/ncol) + # plotting if (print) { makeMain() makeElements() makeConstructs() - colorRow(cr) # color current row or column + colorRow(cr) # color current row or column colorColumn(cc) } else { renewColumn(cc.old) renewRow(cr.old) colorRow(cr) colorColumn(cc) - } - #par(op) + } + # par(op) invisible(NULL) } -#bertinBase(20, 70, xlim=c(.2,.8), ylim=c(0,.4)) -#bertinBase(10,20) -#bertinBase(10,20, xlim=c(0.1, .9), ylim=c(.2, .8), cex.text=.8) -#bertinBase(20, 30, grey(runif(13)), cex.text=.6) -#labels <- randomSentences(20, 6) -#bertinBase(20, 70, xlim=c(.25,.75), ylim=c(.1,.4), margins=c(.03,.9,.97), id=F, +# bertinBase(20, 70, xlim=c(.2,.8), ylim=c(0,.4)) +# bertinBase(10,20) +# bertinBase(10,20, xlim=c(0.1, .9), ylim=c(.2, .8), cex.text=.8) +# bertinBase(20, 30, grey(runif(13)), cex.text=.6) +# labels <- randomSentences(20, 6) +# bertinBase(20, 70, xlim=c(.25,.75), ylim=c(.1,.4), margins=c(.03,.9,.97), id=F, # labels.l=labels, labels.ri=labels, labels.el=rep(labels, 4)) - -#x <- randomGrid(20, 40) -#nc <- length(x@constructs) -#ne <- length(x@elements) -#color <- c("darkred", "white", "darkgreen") -#colorFun <- makeStandardRangeColorRamp(color) -#scale.min <- x@scale$min -#scale.max <- x@scale$max -#scores <- as.vector(x@ratings[,,1]) -#col.fill <- colorFun((scores-scale.min)/(scale.max-scale.min)) -#bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white") -#bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white", cc=10, cr=10, pri=F) -#bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white", cc.old=10, pri=F) -#bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white", cr.old=10, pri=F) - -#bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white") -#for (row in 1:10){ + +# x <- randomGrid(20, 40) +# nc <- length(x@constructs) +# ne <- length(x@elements) +# color <- c("darkred", "white", "darkgreen") +# colorFun <- makeStandardRangeColorRamp(color) +# scale.min <- x@scale$min +# scale.max <- x@scale$max +# scores <- as.vector(x@ratings[,,1]) +# col.fill <- colorFun((scores-scale.min)/(scale.max-scale.min)) +# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white") +# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white", cc=10, cr=10, pri=F) +# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white", cc.old=10, pri=F) +# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white", cr.old=10, pri=F) + +# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, border="white") +# for (row in 1:10){ # for (col in 1:15) { -# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, +# bertinBase(nc, ne, col.fill, scores , xlim=c(.2, .8), ylim=c(0,.6), cex.text=.6, # border="white", cc=col, cr=row, cc.old=col -1, cr.old=row-1, pri=F) # Sys.sleep(.2) # } -#} +# } #' Make Bertin display of grid data. @@ -463,22 +499,22 @@ bertinBase <- function(nrow, ncol, labels="", labels.elements="", #' (2000) and Raeithel (1998). #' #' @param x `repgrid` object. -#' @param colors Vector. Two or more colors defining the color ramp for +#' @param colors Vector. Two or more colors defining the color ramp for #' the bertin (default `c("white", "black")`). #' @param showvalues Logical. Whether scores are shown in bertin -#' @param xlim Vector. Left and right limits inner bertin (default +#' @param xlim Vector. Left and right limits inner bertin (default #' `c(.2, .8)`). #' @param ylim Vector. Lower and upper limits of inner bertin #' default(`c(.0, .6)`). -#' @param margins Vector of length three (default `margins=c(0,1,1)`). -#' 1st element denotes the left, 2nd the upper and 3rd the +#' @param margins Vector of length three (default `margins=c(0,1,1)`). +#' 1st element denotes the left, 2nd the upper and 3rd the #' right margin in npc coordinates (i.e. 0 to zero). #' @param cex.elements Numeric. Text size of element labels (default `.7`). #' @param cex.constructs Numeric. Text size of construct labels (default `.7`). #' @param cex.text Numeric. Text size of scores in bertin cells (default `.7`). #' @param col.text Color of scores in bertin (default `NA`). By default -#' the color of the text is chosen according to the -#' background color. If the background ist bright the text +#' the color of the text is chosen according to the +#' background color. If the background ist bright the text #' will be black and vice versa. When a color is specified #' the color is set independent of background. #' @param border Border color of the bertin cells (default `white`). @@ -505,47 +541,51 @@ bertinBase <- function(nrow, ncol, labels="", labels.elements="", #' Raeithel, A. (1998). Kooperative Modellproduktion von Professionellen und Klienten - erlauetert am Beispiel des #' Repertory Grid. *Selbstorganisation, Kooperation, Zeichenprozess: Arbeiten zu einer kulturwissenschaftlichen, #' anwendungsbezogenen Psychologie* (pp. 209-254). Opladen: Westdeutscher Verlag. -#' +#' #' @examples -#' -#' bertin(feixas2004) -#' bertin(feixas2004, c("white", "darkblue")) -#' bertin(feixas2004, showvalues=FALSE) -#' bertin(feixas2004, border="grey") -#' bertin(feixas2004, cex.text=.9) -#' bertin(feixas2004, id=c(FALSE, FALSE)) -#' -#' bertin(feixas2004, cc=3, cr=4) -#' bertin(feixas2004, cc=3, cr=4, col.mark.fill="#e6e6e6") -#' -bertin <- function(x, colors=c("white", "black"), showvalues=TRUE, - xlim=c(.2, .8), ylim=c(0,.6), margins=c(0,1,1), - cex.elements=.7, cex.constructs=.7, cex.text=.6, col.text=NA, - border="white", lheight=.75, id=c(T,T), - cc=0, cr=0, cc.old=0, cr.old=0, col.mark.fill="#FCF5A4", print=TRUE, - ...){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - +#' +#' bertin(feixas2004) +#' bertin(feixas2004, c("white", "darkblue")) +#' bertin(feixas2004, showvalues = FALSE) +#' bertin(feixas2004, border = "grey") +#' bertin(feixas2004, cex.text = .9) +#' bertin(feixas2004, id = c(FALSE, FALSE)) +#' +#' bertin(feixas2004, cc = 3, cr = 4) +#' bertin(feixas2004, cc = 3, cr = 4, col.mark.fill = "#e6e6e6") +#' +bertin <- function(x, colors = c("white", "black"), showvalues = TRUE, + xlim = c(.2, .8), ylim = c(0, .6), margins = c(0, 1, 1), + cex.elements = .7, cex.constructs = .7, cex.text = .6, col.text = NA, + border = "white", lheight = .75, id = c(T, T), + cc = 0, cr = 0, cc.old = 0, cr.old = 0, col.mark.fill = "#FCF5A4", print = TRUE, + ...) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + nc <- length(x@constructs) ne <- length(x@elements) colorFun <- makeStandardRangeColorRamp(colors) scale.min <- x@scale$min scale.max <- x@scale$max - scores <- as.vector(x@ratings[,,1]) - scores.standardized <- (scores-scale.min)/(scale.max-scale.min) + scores <- as.vector(x@ratings[, , 1]) + scores.standardized <- (scores - scale.min) / (scale.max - scale.min) col.fill <- colorFun(scores.standardized) - if (!showvalues) + if (!showvalues) { scores <- recycle("", nc * ne) - bertinBase(nrow=nc, ncol=ne, labels=scores, labels.elements=elements(x), - labels.left=constructs(x)$leftpole, - labels.right=constructs(x)$rightpole, - col.fill=col.fill, - xlim=xlim, ylim=ylim, margins=margins, - cex.elements=cex.elements, cex.constructs=cex.elements, - cex.text=cex.text, col.text=col.text, - border=border, lheight=lheight, id=id, cc=cc, cr=cr, cc.old=cc.old, cr.old=cr.old, - col.mark.fill=col.mark.fill, print=print, ...) + } + bertinBase( + nrow = nc, ncol = ne, labels = scores, labels.elements = elements(x), + labels.left = constructs(x)$leftpole, + labels.right = constructs(x)$rightpole, + col.fill = col.fill, + xlim = xlim, ylim = ylim, margins = margins, + cex.elements = cex.elements, cex.constructs = cex.elements, + cex.text = cex.text, col.text = col.text, + border = border, lheight = lheight, id = id, cc = cc, cr = cr, cc.old = cc.old, cr.old = cr.old, + col.mark.fill = col.mark.fill, print = print, ... + ) invisible(NULL) } @@ -556,20 +596,20 @@ bertin <- function(x, colors=c("white", "black"), showvalues=TRUE, #' cluster methods are supported. #' #' @param x `repgrid` object. -#' @param dmethod The distance measure to be used. This must be one of -#' `"euclidean"`, `"maximum"`, `"manhattan"`, +#' @param dmethod The distance measure to be used. This must be one of +#' `"euclidean"`, `"maximum"`, `"manhattan"`, #' `"canberra"`, `"binary"`, or `"minkowski"`. #' Default is `"euclidean"`. -#' Any unambiguous substring can be given (e.g. `"euc"` -#' for `"euclidean"`). +#' Any unambiguous substring can be given (e.g. `"euc"` +#' for `"euclidean"`). #' A vector of length two can be passed if a different distance measure for #' constructs and elements is wanted (e.g.`c("euclidean", "manhattan")`). #' This will apply euclidean distance to the constructs and #' manhattan distance to the elements. #' For additional information on the different types see -#' `?dist`. +#' `?dist`. #' @param cmethod The agglomeration method to be used. This should be (an -#' unambiguous abbreviation of) one of `"ward.D"`, `"ward.D2"`, +#' unambiguous abbreviation of) one of `"ward.D"`, `"ward.D2"`, #' `"single"`, `"complete"`, `"average"`, `"mcquitty"`, `"median"` or `"centroid"`. #' Default is `"ward.D"`. #' A vector of length two can be passed if a different cluster method for @@ -583,30 +623,30 @@ bertin <- function(x, colors=c("white", "black"), showvalues=TRUE, #' of length two if different powers are wanted for constructs and #' elements respectively (e.g. `c(2,1)`). #' @param align Whether the constructs should be aligned before clustering -#' (default is `TRUE`). If not, the grid matrix is clustered +#' (default is `TRUE`). If not, the grid matrix is clustered #' as is. See Details section in function [cluster()] for more information. #' @param trim The number of characters a construct is trimmed to (default is #' `10`). If `NA` no trimming is done. Trimming #' simply saves space when displaying the output. -#' @param type Type of dendrogram. Either or `"triangle"` (default) +#' @param type Type of dendrogram. Either or `"triangle"` (default) #' or `"rectangle"` form. #' @param xsegs Numeric vector of normal device coordinates (ndc i.e. 0 to 1) to mark #' the widths of the regions for the left labels, for the -#' bertin display, for the right labels and for the +#' bertin display, for the right labels and for the #' vertical dendrogram (i.e. for the constructs). #' @param ysegs Numeric vector of normal device coordinates (ndc i.e. 0 to 1) to mark -#' the heights of the regions for the horizontal dendrogram -#' (i.e. for the elements), for the bertin display and for +#' the heights of the regions for the horizontal dendrogram +#' (i.e. for the elements), for the bertin display and for #' the element names. -#' @param x.off Horizontal offset between construct labels and construct dendrogram and -# between the outer right margin and the dendrogram +#' @param x.off Horizontal offset between construct labels and construct dendrogram and +# between the outer right margin and the dendrogram #' (default is `0.01` in normal device coordinates). -#' @param y.off Vertical offset between bertin display and element dendrogram and +#' @param y.off Vertical offset between bertin display and element dendrogram and # between the lower margin and the dendrogram #' (default is `0.01` in normal device coordinates). #' @param cex.axis `cex` for axis labels, default is `.6`. #' @param col.axis Color for axis and axis labels, default is `grey(.4)`. -#' @param draw.axis Whether to draw axis showing the distance metric for the dendrograms +#' @param draw.axis Whether to draw axis showing the distance metric for the dendrograms #' (default is `TRUE`). #' @param ... additional parameters to be passed to function [bertin()]. #' @@ -616,141 +656,151 @@ bertin <- function(x, colors=c("white", "black"), showvalues=TRUE, #' @seealso [cluster()] #' @examples #' -#' # default is euclidean distance and ward clustering -#' bertinCluster(bell2010) +#' # default is euclidean distance and ward clustering +#' bertinCluster(bell2010) +#' +#' ### applying different distance measures and cluster methods #' -#' ### applying different distance measures and cluster methods +#' # euclidean distance and single linkage clustering +#' bertinCluster(bell2010, cmethod = "single") +#' # manhattan distance and single linkage clustering +#' bertinCluster(bell2010, dmethod = "manhattan", cm = "single") +#' # minkowksi distance with power of 2 = euclidean distance +#' bertinCluster(bell2010, dm = "mink", p = 2) #' -#' # euclidean distance and single linkage clustering -#' bertinCluster(bell2010, cmethod="single") -#' # manhattan distance and single linkage clustering -#' bertinCluster(bell2010, dmethod="manhattan", cm="single") -#' # minkowksi distance with power of 2 = euclidean distance -#' bertinCluster(bell2010, dm="mink", p=2) -#' -#' ### using different methods for constructs and elements +#' ### using different methods for constructs and elements #' -#' # ward clustering for constructs, single linkage for elements -#' bertinCluster(bell2010, cmethod=c("ward.D", "single")) -#' # euclidean distance measure for constructs, manhatten -#' # distance for elements -#' bertinCluster(bell2010, dmethod=c("euclidean", "man")) -#' # minkowski metric with different powers for constructs and elements -#' bertinCluster(bell2010, dmethod="mink", p=c(2,1)) +#' # ward clustering for constructs, single linkage for elements +#' bertinCluster(bell2010, cmethod = c("ward.D", "single")) +#' # euclidean distance measure for constructs, manhatten +#' # distance for elements +#' bertinCluster(bell2010, dmethod = c("euclidean", "man")) +#' # minkowski metric with different powers for constructs and elements +#' bertinCluster(bell2010, dmethod = "mink", p = c(2, 1)) #' -#' ### clustering either constructs or elements only -#' # euclidean distance and ward clustering for constructs no -#' # clustering for elements -#' bertinCluster(bell2010, cmethod=c("ward.D", NA)) -#' # euclidean distance and single linkage clustering for elements -#' # no clustering for constructs -#' bertinCluster(bell2010, cm=c(NA, "single"), align=FALSE) +#' ### clustering either constructs or elements only +#' # euclidean distance and ward clustering for constructs no +#' # clustering for elements +#' bertinCluster(bell2010, cmethod = c("ward.D", NA)) +#' # euclidean distance and single linkage clustering for elements +#' # no clustering for constructs +#' bertinCluster(bell2010, cm = c(NA, "single"), align = FALSE) #' -#' ### changing the appearance -#' # different dendrogram type -#' bertinCluster(bell2010, type="rectangle") -#' # no axis drawn for dendrogram -#' bertinCluster(bell2010, draw.axis=FALSE) +#' ### changing the appearance +#' # different dendrogram type +#' bertinCluster(bell2010, type = "rectangle") +#' # no axis drawn for dendrogram +#' bertinCluster(bell2010, draw.axis = FALSE) #' -#' ### passing on arguments to bertin function via ... -#' # grey cell borders in bertin display -#' bertinCluster(bell2010, border="grey") -#' # omit printing of grid scores, i.e. colors only -#' bertinCluster(bell2010, showvalues=FALSE) +#' ### passing on arguments to bertin function via ... +#' # grey cell borders in bertin display +#' bertinCluster(bell2010, border = "grey") +#' # omit printing of grid scores, i.e. colors only +#' bertinCluster(bell2010, showvalues = FALSE) #' -#' ### changing the layout -#' # making the vertical dendrogram bigger -#' bertinCluster(bell2010, xsegs=c(0, .2, .5, .7, 1)) -#' # making the horizontal dendrogram bigger -#' bertinCluster(bell2010, ysegs=c(0, .3, .8, 1)) -#' -bertinCluster <- function(x, dmethod=c("euclidean", "euclidean"), - cmethod=c("ward.D", "ward.D"), p=c(2,2), align=TRUE, - trim=NA, type=c("triangle"), +#' ### changing the layout +#' # making the vertical dendrogram bigger +#' bertinCluster(bell2010, xsegs = c(0, .2, .5, .7, 1)) +#' # making the horizontal dendrogram bigger +#' bertinCluster(bell2010, ysegs = c(0, .3, .8, 1)) +#' +bertinCluster <- function(x, dmethod = c("euclidean", "euclidean"), + cmethod = c("ward.D", "ward.D"), p = c(2, 2), align = TRUE, + trim = NA, type = c("triangle"), xsegs = c(0, .2, .7, .9, 1), ysegs = c(0, .1, .7, 1), - x.off=0.01, y.off=0.01, - cex.axis =.6, col.axis = grey(.4), draw.axis=TRUE, ...) { - - if (length(dmethod) == 1) # if only one value is passed + x.off = 0.01, y.off = 0.01, + cex.axis = .6, col.axis = grey(.4), draw.axis = TRUE, ...) { + if (length(dmethod) == 1) { # if only one value is passed dmethod <- rep(dmethod, 2) - if (length(cmethod) == 1) # if only one value is passed + } + if (length(cmethod) == 1) { # if only one value is passed cmethod <- rep(cmethod, 2) - if (length(p) == 1) # if only one value is passed + } + if (length(p) == 1) { # if only one value is passed p <- rep(p, 2) + } + + cex.dend <- 0.001 # size text dendrogram, only needed for sanity + # check purposes, otherwise 0.001 so no dend labels are drawn - cex.dend <- 0.001 # size text dendrogram, only needed for sanity - # check purposes, otherwise 0.001 so no dend labels are drawn - - inr.x <- xsegs[4] # inner figure region (bertin) ndc x coordinate range - # range goes from left side to y dendrogram region - inr.y <- 1 - ysegs[2] # bertin fig region range as ndc coords - # range goes from end of x dendrogram region to end of device (i.e. 1) - - # transform xsegs and ysegs coordinates (ndc) into + inr.x <- xsegs[4] # inner figure region (bertin) ndc x coordinate range + # range goes from left side to y dendrogram region + inr.y <- 1 - ysegs[2] # bertin fig region range as ndc coords + # range goes from end of x dendrogram region to end of device (i.e. 1) + + # transform xsegs and ysegs coordinates (ndc) into # ndc coordinates for inner figure region used by bertin plot xlim.bertin <- xsegs[2:3] / inr.x ylim.bertin <- c(0, (ysegs[3] - ysegs[2]) / inr.y) - + # align grid if promoted, uses dmethod etc. for constructs, i.e. [1] - if (align) { - x <- align(x, along = 0, dmethod = dmethod[1], - cmethod = cmethod[1], p = p[1]) + if (align) { + x <- align(x, + along = 0, dmethod = dmethod[1], + cmethod = cmethod[1], p = p[1] + ) } - r <- getRatingLayer(x, trim=trim) + r <- getRatingLayer(x, trim = trim) # dendrogram for constructs - if (is.na(cmethod[1])){ - con.ord <- seq_len(getNoOfConstructs(x)) # no change in order + if (is.na(cmethod[1])) { + con.ord <- seq_len(getNoOfConstructs(x)) # no change in order fit.constructs <- NULL } else { - dc <- dist(r, method = dmethod[1], p=p[1]) # make distance matrix for constructs - fit.constructs <- hclust(dc, method=cmethod[1]) # hclust object for constructs + dc <- dist(r, method = dmethod[1], p = p[1]) # make distance matrix for constructs + fit.constructs <- hclust(dc, method = cmethod[1]) # hclust object for constructs dend.con <- as.dendrogram(fit.constructs) con.ord <- order.dendrogram(rev(dend.con)) } - + # dendrogram for elements - if (is.na(cmethod[2])){ - el.ord <- seq_len(getNoOfConstructs(x)) # no change in order + if (is.na(cmethod[2])) { + el.ord <- seq_len(getNoOfConstructs(x)) # no change in order fit.elements <- NULL } else { - de <- dist(t(r), method = dmethod[2], p=p[2]) # make distance matrix for elements - fit.elements <- hclust(de, method=cmethod[2]) # hclust object for elements + de <- dist(t(r), method = dmethod[2], p = p[2]) # make distance matrix for elements + fit.elements <- hclust(de, method = cmethod[2]) # hclust object for elements dend.el <- as.dendrogram(fit.elements) el.ord <- order.dendrogram(dend.el) } - - x <- x[con.ord, el.ord] # reorder repgrid object - + + x <- x[con.ord, el.ord] # reorder repgrid object + plot.new() - par(fig = c(xsegs[c(1,4)], ysegs[c(2,4)]), new=TRUE) - #par(fig = c(0, .8, .2, 1), new=T) - - bertin(x, xlim=xlim.bertin, ylim=ylim.bertin, add=TRUE, ...) # print reordered bertin - + par(fig = c(xsegs[c(1, 4)], ysegs[c(2, 4)]), new = TRUE) + # par(fig = c(0, .8, .2, 1), new=T) + + bertin(x, xlim = xlim.bertin, ylim = ylim.bertin, add = TRUE, ...) # print reordered bertin + # x dendrogram (horizontal) elements - if (!is.na(cmethod[2])){ - dend.x.fig <- c(xsegs[2:3], ysegs[1:2]) + c(0,0, y.off, -y.off) # adjust for offsets - par(fig = dend.x.fig, new=T, mar=c(0,0,0,0)) + if (!is.na(cmethod[2])) { + dend.x.fig <- c(xsegs[2:3], ysegs[1:2]) + c(0, 0, y.off, -y.off) # adjust for offsets + par(fig = dend.x.fig, new = T, mar = c(0, 0, 0, 0)) ymax.el <- attr(dend.el, "height") - plot(dend.el, horiz=F, xlab="", xaxs="i", yaxs="i", yaxt="n", - nodePar=list(cex=0, lab.cex=cex.dend), ylim=c(ymax.el,0), type=type) - if (draw.axis) # whether to draw axis - axis(2, las=1, cex.axis=cex.axis, col=col.axis, col.axis=col.axis) + plot(dend.el, + horiz = F, xlab = "", xaxs = "i", yaxs = "i", yaxt = "n", + nodePar = list(cex = 0, lab.cex = cex.dend), ylim = c(ymax.el, 0), type = type + ) + if (draw.axis) { # whether to draw axis + axis(2, las = 1, cex.axis = cex.axis, col = col.axis, col.axis = col.axis) + } } - + # y dendrogram (vertical) constructs - if (!is.na(cmethod[1])){ - dend.y.fig <- c(xsegs[4:5], ysegs[2:3]) + c(x.off, -x.off, 0, 0) # adjust for offsets - par(fig = dend.y.fig, new=T, mar=c(0,0,0,0)) + if (!is.na(cmethod[1])) { + dend.y.fig <- c(xsegs[4:5], ysegs[2:3]) + c(x.off, -x.off, 0, 0) # adjust for offsets + par(fig = dend.y.fig, new = T, mar = c(0, 0, 0, 0)) xmax.con <- attr(dend.con, "height") - plot(dend.con, horiz=T, xlab="", xaxs="i", yaxs="i", yaxt="n", - nodePar=list(cex=0, lab.cex=cex.dend), xlim=c(0,xmax.con), type=type) - if (draw.axis) # whether to draw axis - axis(1, las=1, cex.axis=cex.axis, col=col.axis, col.axis= col.axis) + plot(dend.con, + horiz = T, xlab = "", xaxs = "i", yaxs = "i", yaxt = "n", + nodePar = list(cex = 0, lab.cex = cex.dend), xlim = c(0, xmax.con), type = type + ) + if (draw.axis) { # whether to draw axis + axis(1, las = 1, cex.axis = cex.axis, col = col.axis, col.axis = col.axis) + } } # return hclust objects for elements and constructs - invisible(list(constructs=fit.constructs, elements=fit.elements)) + invisible(list(constructs = fit.constructs, elements = fit.elements)) } # TODO: use of layout does not work with bertinCluster diff --git a/R/calc.r b/R/calc.r index 51463c0d..b930a6ef 100644 --- a/R/calc.r +++ b/R/calc.r @@ -1,8 +1,7 @@ - #' Descriptive statistics for constructs and elements #' #' Several descriptive measures for constructs and elements. -#' +#' #' @param x `repgrid` object. #' @param index Whether to print the number of the element. #' @param trim The number of characters an element or a construct is trimmed to (default is `20`). If `NA` no trimming @@ -30,37 +29,39 @@ #' @rdname stats #' @examples #' -#' statsConstructs(fbb2003) -#' statsConstructs(fbb2003, trim=10) -#' statsConstructs(fbb2003, trim=10, index=FALSE) -#' -#' statsElements(fbb2003) -#' statsElements(fbb2003, trim=10) -#' statsElements(fbb2003, trim=10, index=FALSE) -#' -#' # save the access the results -#' d <- statsElements(fbb2003) -#' d -#' d["mean"] -#' d[2, "mean"] # mean rating of 2nd element -#' -#' d <- statsConstructs(fbb2003) -#' d -#' d["sd"] -#' d[1, "sd"] # sd of ratings on first construct -#' -statsElements <- function(x, index=TRUE, trim=20) -{ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") +#' statsConstructs(fbb2003) +#' statsConstructs(fbb2003, trim = 10) +#' statsConstructs(fbb2003, trim = 10, index = FALSE) +#' +#' statsElements(fbb2003) +#' statsElements(fbb2003, trim = 10) +#' statsElements(fbb2003, trim = 10, index = FALSE) +#' +#' # save the access the results +#' d <- statsElements(fbb2003) +#' d +#' d["mean"] +#' d[2, "mean"] # mean rating of 2nd element +#' +#' d <- statsConstructs(fbb2003) +#' d +#' d["sd"] +#' d[1, "sd"] # sd of ratings on first construct +#' +statsElements <- function(x, index = TRUE, trim = 20) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } s <- getRatingLayer(x) - res <- describe(s) # psych function - enames <- getElementNames2(x, index=index, trim=trim) + res <- describe(s) # psych function + enames <- getElementNames2(x, index = index, trim = trim) ne <- getNoOfElements(x) - if (length(unique(enames)) != ne){ - stop("please chose a longer value for 'trim' or set 'index' to TRUE", - "as the current value produces indentical rownames") - } + if (length(unique(enames)) != ne) { + stop( + "please chose a longer value for 'trim' or set 'index' to TRUE", + "as the current value produces indentical rownames" + ) + } rownames(res) <- enames class(res) <- c("statsElements", "data.frame") return(res) @@ -69,17 +70,16 @@ statsElements <- function(x, index=TRUE, trim=20) #' Print method for class statsElements -#' +#' #' @param x Object of class statsElements. -#' @param digits Numeric. Number of digits to round to (default is +#' @param digits Numeric. Number of digits to round to (default is #' `1`). #' @param ... Not evaluated. #' @export #' @method print statsElements #' @keywords internal #' -print.statsElements <- function(x, digits=2, ...) -{ +print.statsElements <- function(x, digits = 2, ...) { cat("\n##################################") cat("\nDesriptive statistics for elements") cat("\n##################################\n\n") @@ -90,12 +90,13 @@ print.statsElements <- function(x, digits=2, ...) #' @export #' @rdname stats -statsConstructs <- function(x, index=T, trim=20){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") +statsConstructs <- function(x, index = T, trim = 20) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } s <- getRatingLayer(x) res <- describe(t(s)) - cnames <- getConstructNames2(x, index=index, trim=trim) + cnames <- getConstructNames2(x, index = index, trim = trim) rownames(res) <- cnames class(res) <- c("statsConstructs", "data.frame") return(res) @@ -104,17 +105,16 @@ statsConstructs <- function(x, index=T, trim=20){ #' Print method for class statsConstructs -#' +#' #' @param x Object of class statsConstructs. -#' @param digits Numeric. Number of digits to round to (default is +#' @param digits Numeric. Number of digits to round to (default is #' `1`). #' @param ... Not evaluated. #' @export #' @method print statsConstructs #' @keywords internal #' -print.statsConstructs <- function(x, digits=2, ...) -{ +print.statsConstructs <- function(x, digits = 2, ...) { cat("\n####################################") cat("\nDesriptive statistics for constructs") cat("\n####################################\n\n") @@ -123,8 +123,8 @@ print.statsConstructs <- function(x, digits=2, ...) } -getScoreDataFrame <- function(x){ - sc <- x@ratings[,,1] +getScoreDataFrame <- function(x) { + sc <- x@ratings[, , 1] rownames(sc) <- constructs(x)$l colnames(sc) <- elements(x) sc @@ -133,28 +133,32 @@ getScoreDataFrame <- function(x){ # disc element to be used as discrepancy # remove logical. remove element that was used as discrepancy # -makeDiscrepancy <- function(x, disc, remove=TRUE){ - sc <- x@ratings[,,1] +makeDiscrepancy <- function(x, disc, remove = TRUE) { + sc <- x@ratings[, , 1] colnames(sc) <- elements(x) scDiscElement <- sc[, disc] - if (remove) - sc[, -disc] - scDiscElement else - sc[,] - scDiscElement + if (remove) { + sc[, -disc] - scDiscElement + } else { + sc[, ] - scDiscElement + } } -statsDiscrepancy <- function(x, disc, sort=TRUE){ +statsDiscrepancy <- function(x, disc, sort = TRUE) { a <- describe(makeDiscrepancy(x, disc)) - if (sort) - a[order(a$mean),] else - a + if (sort) { + a[order(a$mean), ] + } else { + a + } } -#///////////////////////////////////////////////////////////////////////////// +# ///////////////////////////////////////////////////////////////////////////// # order elements and constructs by angles in first two dimensions from # singular value decomposition approach (cf. Raeithel ???) -#///////////////////////////////////////////////////////////////////////////// +# ///////////////////////////////////////////////////////////////////////////// #' Calculate angles for points in first two columns. #' @@ -171,12 +175,13 @@ statsDiscrepancy <- function(x, disc, sort=TRUE){ #' m <- matrix(rnorm(9), 3) #' calcAngles() #' } -calcAngles <- function(x, dim=c(1,2), clockwise=TRUE){ - angles <- atan2(x[ ,dim[2]], x[ ,dim[1]]) / (2 * pi / 360) - angles <- angles * -1 # positive angles are counted clockwise atan2 does anticlockwise by default - angles[angles < 0] <- 360 + angles[angles < 0] # map to 0 to 360 degrees i.e. only positive values for ordering - if (!clockwise) +calcAngles <- function(x, dim = c(1, 2), clockwise = TRUE) { + angles <- atan2(x[, dim[2]], x[, dim[1]]) / (2 * pi / 360) + angles <- angles * -1 # positive angles are counted clockwise atan2 does anticlockwise by default + angles[angles < 0] <- 360 + angles[angles < 0] # map to 0 to 360 degrees i.e. only positive values for ordering + if (!clockwise) { angles <- 360 - angles + } angles } @@ -194,21 +199,24 @@ calcAngles <- function(x, dim=c(1,2), clockwise=TRUE){ #' @keywords internal #' @examples \dontrun{ #' -#' x <- randomGrid(15,30) # make random grid -#' i <- angleOrderIndexes2d(x) # make indexes for ordering -#' x <- x[i[[1]], i[[2]]] # reorder constructs and elements -#' x # print grid +#' x <- randomGrid(15, 30) # make random grid +#' i <- angleOrderIndexes2d(x) # make indexes for ordering +#' x <- x[i[[1]], i[[2]]] # reorder constructs and elements +#' x # print grid #' } -#' -angleOrderIndexes2d <- function(x, dim=c(1,2), clockwise=TRUE) { - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") +#' +angleOrderIndexes2d <- function(x, dim = c(1, 2), clockwise = TRUE) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } E.mat <- x@calcs$biplot$elem C.mat <- x@calcs$biplot$con - C.angles <- calcAngles(C.mat, dim=dim, clockwise=clockwise) - E.angles <- calcAngles(E.mat, dim=dim, clockwise=clockwise) - list(c.order=order(C.angles), - e.order=order(E.angles)) + C.angles <- calcAngles(C.mat, dim = dim, clockwise = clockwise) + E.angles <- calcAngles(E.mat, dim = dim, clockwise = clockwise) + list( + c.order = order(C.angles), + e.order = order(E.angles) + ) } @@ -222,47 +230,50 @@ angleOrderIndexes2d <- function(x, dim=c(1,2), clockwise=TRUE) { #' @param x `repgrid` object. #' @param dim Dimension of 2D solution used to calculate angles #' (default `c(1,2)`). -#' @param center Numeric. The type of centering to be performed. -#' `0`= no centering, `1`= row mean centering (construct), +#' @param center Numeric. The type of centering to be performed. +#' `0`= no centering, `1`= row mean centering (construct), #' `2`= column mean centering (elements), `3`= double-centering (construct and element means), #' `4`= midpoint centering of rows (constructs). #' The default is `1` (row centering). #' @param normalize A numeric value indicating along what direction (rows, columns) #' to normalize by standard deviations. `0 = none, 1= rows, 2 = columns` #' (default is `0`). -#' @param g Power of the singular value matrix assigned to the left singular +#' @param g Power of the singular value matrix assigned to the left singular #' vectors, i.e. the constructs. -#' @param h Power of the singular value matrix assigned to the right singular +#' @param h Power of the singular value matrix assigned to the right singular #' vectors, i.e. the elements. #' @param rc Logical. Reorder constructs by similarity (default `TRUE`). #' @param re Logical. Reorder elements by similarity (default `TRUE`). #' @param ... Not evaluated. #' -#' @return Reordered `repgrid` object. +#' @return Reordered `repgrid` object. #' #' @export #' @examples #' -#' x <- feixas2004 -#' reorder2d(x) # reorder grid by angles in first two dimensions -#' reorder2d(x, rc=FALSE) # reorder elements only -#' reorder2d(x, re=FALSE) # reorder constructs only -#' -reorder2d <- function(x, dim=c(1,2), center=1, normalize=0, g=0, h=1-g, - rc=TRUE, re=TRUE, ... ) { - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - x <- calcBiplotCoords(x, center=center, normalize=normalize, g=g, h=h, ...) - i <- angleOrderIndexes2d(x, dim=dim) # make indexes for ordering - if(rc) - x <- x[i[[1]], ,drop=FALSE] - if(re) - x <- x[ ,i[[2]], drop=FALSE] +#' x <- feixas2004 +#' reorder2d(x) # reorder grid by angles in first two dimensions +#' reorder2d(x, rc = FALSE) # reorder elements only +#' reorder2d(x, re = FALSE) # reorder constructs only +#' +reorder2d <- function(x, dim = c(1, 2), center = 1, normalize = 0, g = 0, h = 1 - g, + rc = TRUE, re = TRUE, ...) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + x <- calcBiplotCoords(x, center = center, normalize = normalize, g = g, h = h, ...) + i <- angleOrderIndexes2d(x, dim = dim) # make indexes for ordering + if (rc) { + x <- x[i[[1]], , drop = FALSE] + } + if (re) { + x <- x[, i[[2]], drop = FALSE] + } x } - + #### __________________ #### #### ELEMENTS #### @@ -294,80 +305,84 @@ reorder2d <- function(x, dim=c(1,2), center=1, normalize=0, g=0, h=1-g, #' @export #' @seealso [constructCor()] #' @examples -#' elementCor(mackay1992) # Cohen's rc -#' elementCor(mackay1992, rc=FALSE) # PM correlation -#' elementCor(mackay1992, rc=FALSE, method="spearman") # Spearman correlation -#' -#' # format output -#' elementCor(mackay1992, trim=6) -#' elementCor(mackay1992, index=FALSE, trim=6) -#' -#' # save as object for further processing -#' r <- elementCor(mackay1992) -#' r -#' -#' # change output of object -#' print(r, digits=5) -#' print(r, col.index=FALSE) -#' print(r, upper=FALSE) -#' -#' # accessing elements of the correlation matrix -#' r[1,3] -#' -elementCor <- function(x, rc=TRUE, method="pearson", - trim=20, index=TRUE) { - method <- match.arg(method, c("pearson", "kendall", "spearman")) - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") +#' elementCor(mackay1992) # Cohen's rc +#' elementCor(mackay1992, rc = FALSE) # PM correlation +#' elementCor(mackay1992, rc = FALSE, method = "spearman") # Spearman correlation +#' +#' # format output +#' elementCor(mackay1992, trim = 6) +#' elementCor(mackay1992, index = FALSE, trim = 6) +#' +#' # save as object for further processing +#' r <- elementCor(mackay1992) +#' r +#' +#' # change output of object +#' print(r, digits = 5) +#' print(r, col.index = FALSE) +#' print(r, upper = FALSE) +#' +#' # accessing elements of the correlation matrix +#' r[1, 3] +#' +elementCor <- function(x, rc = TRUE, method = "pearson", + trim = 20, index = TRUE) { + method <- match.arg(method, c("pearson", "kendall", "spearman")) + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } if (rc) { - x <- doubleEntry(x) # double entry to get rc correlation - method <- "pearson" # Cohen's rc is only defined for pearson correlation + x <- doubleEntry(x) # double entry to get rc correlation + method <- "pearson" # Cohen's rc is only defined for pearson correlation } scores <- getRatingLayer(x) - res <- cor(scores, method=method) - res <- addNamesToMatrix2(x, res, index=index, trim=trim, along=2) + res <- cor(scores, method = method) + res <- addNamesToMatrix2(x, res, index = index, trim = trim, along = 2) class(res) <- c("elementCor", "matrix") - attr(res, "arguments") <- list(method=method, rc=rc) + attr(res, "arguments") <- list(method = method, rc = rc) res } #' Print method for class elementCor. -#' +#' #' @param x Object of class elementCor -#' @param digits Numeric. Number of digits to round to (default is +#' @param digits Numeric. Number of digits to round to (default is #' `2`). -#' @param col.index Logical. Whether to add an extra index column so the -#' column names are indexes instead of construct names. This option -#' renders a neater output as long construct names will stretch +#' @param col.index Logical. Whether to add an extra index column so the +#' column names are indexes instead of construct names. This option +#' renders a neater output as long construct names will stretch #' the output (default is `TRUE`). -#' @param upper Whether to display upper triangle of correlation matrix only +#' @param upper Whether to display upper triangle of correlation matrix only #' (default is `TRUE`). #' @param ... Not evaluated. #' @export #' @method print elementCor #' @keywords internal -print.elementCor <- function(x, digits=2, col.index=TRUE, upper=TRUE, ...) -{ +print.elementCor <- function(x, digits = 2, col.index = TRUE, upper = TRUE, ...) { args <- attr(x, "arguments") class(x) <- "matrix" x <- round(x, digits) - d <- format(x, nsmall=digits) - + d <- format(x, nsmall = digits) + # console output - if (upper) - d[lower.tri(d, diag=TRUE)] <- paste(rep(" ", digits + 1), collapse="", sep="") - if (col.index) # make index column for neater colnames - d <- addIndexColumnToMatrix(d) + if (upper) { + d[lower.tri(d, diag = TRUE)] <- paste(rep(" ", digits + 1), collapse = "", sep = "") + } + if (col.index) { # make index column for neater colnames + d <- addIndexColumnToMatrix(d) + } d <- as.data.frame(d) cat("\n############################") cat("\nCorrelation between elements") cat("\n############################") - if (args$rc) + if (args$rc) { args$method <- "Cohens's rc (invariant to scale reflection)" + } cat("\n\nType of correlation: ", args$method, "\n") - if (!args$rc) + if (!args$rc) { cat("Note: Standard correlations are not invariant to scale reflection.\n") + } cat("\n") print(d) } @@ -383,12 +398,12 @@ print.elementCor <- function(x, digits=2, col.index=TRUE, upper=TRUE, ...) #' Note that simple element correlations as a measure of similarity are flawed as they are not invariant to construct #' reflection (Mackay, 1992; Bell, 2010). A correlation index invariant to construct reflection is Cohen's rc measure #' (1969), which can be calculated using the argument `rc=TRUE` which is the default option in this function. -#' +#' #' @param x `repgrid` object. -#' @param rc Whether to use Cohen's rc which is invariant to construct +#' @param rc Whether to use Cohen's rc which is invariant to construct #' reflection (see description above). It is used as the default. -#' @param method A character string indicating which correlation coefficient -#' to be computed. One of `"pearson"` (default), +#' @param method A character string indicating which correlation coefficient +#' to be computed. One of `"pearson"` (default), #' `"kendall"` or `"spearman"`, can be abbreviated. #' The default is `"pearson"`. #' @param trim The number of characters an element is trimmed to (default is @@ -402,27 +417,29 @@ print.elementCor <- function(x, digits=2, col.index=TRUE, upper=TRUE, ...) #' #' @references Fransella, F., Bell, R. C., & Bannister, D. (2003). #' *A Manual for Repertory Grid Technique (2. Ed.)*. Chichester: John Wiley & Sons. -#' -#' @examples #' -#' # data from grid manual by Fransella, Bell and Bannister -#' elementRmsCor(fbb2003) -#' elementRmsCor(fbb2003, trim=10) -#' -#' # modify output -#' r <- elementRmsCor(fbb2003) -#' print(r, digits=5) +#' @examples +#' +#' # data from grid manual by Fransella, Bell and Bannister +#' elementRmsCor(fbb2003) +#' elementRmsCor(fbb2003, trim = 10) +#' +#' # modify output +#' r <- elementRmsCor(fbb2003) +#' print(r, digits = 5) #' -#' # access second row of calculation results -#' r[2, "RMS"] +#' # access second row of calculation results +#' r[2, "RMS"] #' elementRmsCor <- function(x, rc = TRUE, method = "pearson", trim = NA) { - method <- match.arg(method, c("pearson", "kendall", "spearman")) - res <- elementCor(x, rc = rc, method = method, trim = trim, - index = TRUE) # calc correlations - diag(res) <- NA # remove diagonal - res <- apply(res^2, 1, mean, na.rm=TRUE) # mean of squared values - res <- data.frame(RMS = res^.5) # root of mean squares + method <- match.arg(method, c("pearson", "kendall", "spearman")) + res <- elementCor(x, + rc = rc, method = method, trim = trim, + index = TRUE + ) # calc correlations + diag(res) <- NA # remove diagonal + res <- apply(res^2, 1, mean, na.rm = TRUE) # mean of squared values + res <- data.frame(RMS = res^.5) # root of mean squares class(res) <- c("rmsCor", "data.frame") attr(res, "type") <- "elements" return(res) @@ -433,69 +450,70 @@ elementRmsCor <- function(x, rc = TRUE, method = "pearson", trim = NA) { #### CONSTRUCTS #### -#' Calculate correlations between constructs. +#' Calculate correlations between constructs. #' -#' Different types of correlations can be requested: +#' Different types of correlations can be requested: #' PMC, Kendall tau rank correlation, Spearman rank correlation. #' #' @param x `repgrid` object. -#' @param method A character string indicating which correlation coefficient -#' is to be computed. One of `"pearson"` (default), +#' @param method A character string indicating which correlation coefficient +#' is to be computed. One of `"pearson"` (default), #' `"kendall"` or `"spearman"`, can be abbreviated. #' The default is `"pearson"`. #' @param trim The number of characters a construct is trimmed to (default is #' `20`). If `NA` no trimming occurs. Trimming #' simply saves space when displaying correlation of constructs #' with long names. -#' @param index Whether to print the number of the construct. +#' @param index Whether to print the number of the construct. #' @return Returns a matrix of construct correlations. #' #' @export #' @seealso [elementCor()] #' -#' @examples -#' -#' # three different types of correlations -#' constructCor(mackay1992) -#' constructCor(mackay1992, method="kendall") -#' constructCor(mackay1992, method="spearman") -#' -#' # format output -#' constructCor(mackay1992, trim=6) -#' constructCor(mackay1992, index=TRUE, trim=6) -#' -#' # save correlation matrix for further processing -#' r <- constructCor(mackay1992) -#' r -#' print(r, digits=5) -#' -#' # accessing the correlation matrix -#' r[1, 3] -#' -constructCor <- function(x, method = c("pearson", "kendall", "spearman"), - trim=20, index=FALSE){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") +#' @examples +#' +#' # three different types of correlations +#' constructCor(mackay1992) +#' constructCor(mackay1992, method = "kendall") +#' constructCor(mackay1992, method = "spearman") +#' +#' # format output +#' constructCor(mackay1992, trim = 6) +#' constructCor(mackay1992, index = TRUE, trim = 6) +#' +#' # save correlation matrix for further processing +#' r <- constructCor(mackay1992) +#' r +#' print(r, digits = 5) +#' +#' # accessing the correlation matrix +#' r[1, 3] +#' +constructCor <- function(x, method = c("pearson", "kendall", "spearman"), + trim = 20, index = FALSE) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } method <- match.arg(method) scores <- getRatingLayer(x) - res <- cor(t(scores), method=method) - res <- addNamesToMatrix2(x, res, index=index, trim=trim) - class(res) <- c("constructCor", "matrix") - attr(res, "arguments") <- list(method=method) + res <- cor(t(scores), method = method) + res <- addNamesToMatrix2(x, res, index = index, trim = trim) + class(res) <- c("constructCor", "matrix") + attr(res, "arguments") <- list(method = method) return(res) } #' Print method for class constructCor. -#' +#' #' @param x Object of class constructCor. -#' @param digits Numeric. Number of digits to round to (default is +#' @param digits Numeric. Number of digits to round to (default is #' `2`). -#' @param col.index Logical. Whether to add an extra index column so the -#' column names are indexes instead of construct names. This option -#' renders a neater output as long construct names will stretch +#' @param col.index Logical. Whether to add an extra index column so the +#' column names are indexes instead of construct names. This option +#' renders a neater output as long construct names will stretch #' the output (default is `TRUE`). -#' @param upper Whether to display upper triangle of correlation matrix only +#' @param upper Whether to display upper triangle of correlation matrix only #' (default is `TRUE`). #' @param header Whether to print additional information in header. #' @param ... Not evaluated. @@ -503,19 +521,21 @@ constructCor <- function(x, method = c("pearson", "kendall", "spearman"), #' @method print constructCor #' @keywords internal #' -print.constructCor <- function(x, digits=2, col.index=TRUE, - upper=TRUE, header=TRUE, ...) -{ +print.constructCor <- function(x, digits = 2, col.index = TRUE, + upper = TRUE, header = TRUE, ...) { args <- attr(x, "arguments") d <- x class(d) <- "matrix" - d <- round(d, digits) - d <- format(d, nsmall=digits) - if (upper) - d[lower.tri(d, diag=TRUE)] <- paste(rep(" ", digits + 1), collapse="", sep="") - if (col.index) # make index column for neater colnames - d <- addIndexColumnToMatrix(d) else - colnames(d) <- seq_len(ncol(d)) + d <- round(d, digits) + d <- format(d, nsmall = digits) + if (upper) { + d[lower.tri(d, diag = TRUE)] <- paste(rep(" ", digits + 1), collapse = "", sep = "") + } + if (col.index) { # make index column for neater colnames + d <- addIndexColumnToMatrix(d) + } else { + colnames(d) <- seq_len(ncol(d)) + } d <- as.data.frame(d) if (header) { cat("\n##############################") @@ -530,16 +550,16 @@ print.constructCor <- function(x, digits=2, col.index=TRUE, #' Root mean square (RMS) of inter-construct correlations. #' -#' The RMS is also known as 'quadratic mean' of -#' the inter-construct correlations. The RMS serves as a simplification of the -#' correlation table. It reflects the average relation of one construct to all -#' other constructs. Note that as the correlations are squared during its calculation, -#' the RMS is not affected by the sign of the correlation (cf. Fransella, +#' The RMS is also known as 'quadratic mean' of +#' the inter-construct correlations. The RMS serves as a simplification of the +#' correlation table. It reflects the average relation of one construct to all +#' other constructs. Note that as the correlations are squared during its calculation, +#' the RMS is not affected by the sign of the correlation (cf. Fransella, #' Bell & Bannister, 2003, p. 86). #' #' @param x `repgrid` object -#' @param method A character string indicating which correlation coefficient -#' is to be computed. One of `"pearson"` (default), +#' @param method A character string indicating which correlation coefficient +#' is to be computed. One of `"pearson"` (default), #' `"kendall"` or `"spearman"`, can be abbreviated. #' The default is `"pearson"`. #' @param trim The number of characters a construct is trimmed to (default is @@ -550,80 +570,81 @@ print.constructCor <- function(x, digits=2, col.index=TRUE, #' @export #' @seealso [elementRmsCor()], [constructCor()] #' -#' @references Fransella, F., Bell, R. C., & Bannister, D. (2003). -#' A Manual for Repertory +#' @references Fransella, F., Bell, R. C., & Bannister, D. (2003). +#' A Manual for Repertory #' Grid Technique (2. Ed.). Chichester: John Wiley & Sons. #' -#' @examples +#' @examples #' -#' # data from grid manual by Fransella, Bell and Bannister -#' constructRmsCor(fbb2003) -#' constructRmsCor(fbb2003, trim=20) -#' -#' # modify output -#' r <- constructRmsCor(fbb2003) -#' print(r, digits=5) +#' # data from grid manual by Fransella, Bell and Bannister +#' constructRmsCor(fbb2003) +#' constructRmsCor(fbb2003, trim = 20) +#' +#' # modify output +#' r <- constructRmsCor(fbb2003) +#' print(r, digits = 5) #' # access calculation results #' r[2, 1] #' constructRmsCor <- function(x, method = "pearson", trim = NA) { - method <- match.arg(method, c("pearson", "kendall", "spearman")) - res <- constructCor(x, method = method, trim=trim, - index=TRUE) # calc correlations - diag(res) <- NA # remove diagonal - res <- apply(res^2, 1, mean, na.rm=TRUE) # mean of squared values - res <- data.frame(RMS = res^.5) # root of mean squares + method <- match.arg(method, c("pearson", "kendall", "spearman")) + res <- constructCor(x, + method = method, trim = trim, + index = TRUE + ) # calc correlations + diag(res) <- NA # remove diagonal + res <- apply(res^2, 1, mean, na.rm = TRUE) # mean of squared values + res <- data.frame(RMS = res^.5) # root of mean squares class(res) <- c("rmsCor", "data.frame") - attr(res, "type") <- "constructs" + attr(res, "type") <- "constructs" return(res) } #' Print method for class rmsCor (RMS correlation for constructs or elements) -#' +#' #' @param x Object of class rmsCor. -#' @param digits Numeric. Number of digits to round to (default is +#' @param digits Numeric. Number of digits to round to (default is #' `2`). #' @param ... Not evaluated. #' @export #' @method print rmsCor #' @keywords internal #' -print.rmsCor <- function(x, digits=2, ...) -{ +print.rmsCor <- function(x, digits = 2, ...) { d <- as.data.frame(x) - d <- round(d, digits) + d <- round(d, digits) type <- attr(x, "type") cat("\n##########################################") cat("\nRoot-mean-square correlation of", type) cat("\n##########################################\n\n") - print(d) - cat("\nAverage of statistic", round(mean(unlist(d), na.rm=TRUE), digits), "\n") - cat("Standard deviation of statistic", round(sdpop(d, na.rm=TRUE), digits), "\n") + print(d) + cat("\nAverage of statistic", round(mean(unlist(d), na.rm = TRUE), digits), "\n") + cat("Standard deviation of statistic", round(sdpop(d, na.rm = TRUE), digits), "\n") } -#' Calculate Somers' d for the constructs. +#' Calculate Somers' d for the constructs. #' -#' Somer's d is an asymmetric association measure as it depends on which +#' Somer's d is an asymmetric association measure as it depends on which #' variable is set as dependent and independent. #' The direction of dependency needs to be specified. #' #' @param x `repgrid` object -#' @param dependent A string denoting the direction of dependency in the output +#' @param dependent A string denoting the direction of dependency in the output #' table (as d is asymmetrical). Possible values are `"columns"` -#' (the default) for setting the columns as dependent, `"rows"` -#' for setting the rows as the dependent variable and -#' `"symmetric"` for the -#' symmetrical Somers' d measure (the mean of the two directional +#' (the default) for setting the columns as dependent, `"rows"` +#' for setting the rows as the dependent variable and +#' `"symmetric"` for the +#' symmetrical Somers' d measure (the mean of the two directional #' values for code{"columns"} and `"rows"`). #' @param trim The number of characters a construct is trimmed to (default is #' `30`). If `NA` no trimming occurs. Trimming #' simply saves space when displaying correlation of constructs #' with long names. -#' @param index Whether to print the number of the construct -#' (default is `TRUE`). +#' @param index Whether to print the number of the construct +#' (default is `TRUE`). #' @return `matrix` of construct correlations. #' @note Thanks to Marc Schwartz for supplying the code to calculate #' Somers' d. @@ -635,77 +656,79 @@ print.rmsCor <- function(x, digits=2, ...) #' #' @examples \dontrun{ #' -#' constructD(fbb2003) # columns as dependent (default) -#' constructD(fbb2003, "c") # row as dependent -#' constructD(fbb2003, "s") # symmetrical index -#' -#' # suppress printing -#' d <- constructD(fbb2003, out=0, trim=5) -#' d -#' -#' # more digits -#' constructD(fbb2003, dig=3) +#' constructD(fbb2003) # columns as dependent (default) +#' constructD(fbb2003, "c") # row as dependent +#' constructD(fbb2003, "s") # symmetrical index #' -#' # add index column, no trimming -#' constructD(fbb2003, col.index=TRUE, index=F, trim=NA) +#' # suppress printing +#' d <- constructD(fbb2003, out = 0, trim = 5) +#' d #' +#' # more digits +#' constructD(fbb2003, dig = 3) +#' +#' # add index column, no trimming +#' constructD(fbb2003, col.index = TRUE, index = F, trim = NA) #' } #' -constructD <- function(x, dependent = "columns", trim=30, index=TRUE) -{ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - dependent <- match.arg(dependent, c("columns", "rows", "symmetric")) +constructD <- function(x, dependent = "columns", trim = 30, index = TRUE) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + dependent <- match.arg(dependent, c("columns", "rows", "symmetric")) scores <- getRatingLayer(x) - l <- lapply(as.data.frame(t(scores)), I) # put each row into a list - - somersd <- function(x, y, dependent, smin, smax){ + l <- lapply(as.data.frame(t(scores)), I) # put each row into a list + + somersd <- function(x, y, dependent, smin, smax) { na.index <- is.na(x) | is.na(y) x <- x[!na.index] y <- y[!na.index] - x <- factor(unlist(x), levels=seq(smin, smax)) - y <- factor(unlist(y), levels=seq(smin, smax)) - m <- as.matrix(table(x,y)) - - if (dependent == "rows") - i <- 1 else - if (dependent == "columns") - i <- 2 else - if (dependent == "symmetric") + x <- factor(unlist(x), levels = seq(smin, smax)) + y <- factor(unlist(y), levels = seq(smin, smax)) + m <- as.matrix(table(x, y)) + + if (dependent == "rows") { + i <- 1 + } else if (dependent == "columns") { + i <- 2 + } else if (dependent == "symmetric") { i <- 3 + } calc.Sd(m)[[i]] - } - + } + nc <- length(l) smin <- x@scale$min smax <- x@scale$max - sds <- mapply(somersd, rep(l,each=nc), rep(l, nc), - MoreArgs=list(dependent=dependent, - smin=smin, smax=smax)) + sds <- mapply(somersd, rep(l, each = nc), rep(l, nc), + MoreArgs = list( + dependent = dependent, + smin = smin, smax = smax + ) + ) res <- matrix(sds, nc) - res <- addNamesToMatrix2(x, res, index=index, trim=trim, along=1) + res <- addNamesToMatrix2(x, res, index = index, trim = trim, along = 1) class(res) <- c("constructD", "matrix") - attr(res, "arguments") <- list(dependent=dependent) + attr(res, "arguments") <- list(dependent = dependent) res } #' Print method for class constructD. -#' +#' #' @param x Object of class constructD. -#' @param digits Numeric. Number of digits to round to (default is +#' @param digits Numeric. Number of digits to round to (default is #' `2`). -#' @param col.index Logical. Whether to add an extra index column so the -#' column names are indexes instead of construct names. This option -#' renders a neater output as long construct names will stretch +#' @param col.index Logical. Whether to add an extra index column so the +#' column names are indexes instead of construct names. This option +#' renders a neater output as long construct names will stretch #' the output (default is `TRUE`). #' @param ... Not evaluated. #' @export #' @method print constructD #' @keywords internal #' -print.constructD <- function(x, digits=1, col.index=TRUE, ...) -{ +print.constructD <- function(x, digits = 1, col.index = TRUE, ...) { class(x) <- "matrix" x <- round(x, digits) args <- attr(x, "arguments") @@ -714,9 +737,11 @@ print.constructD <- function(x, digits=1, col.index=TRUE, ...) cat("\nSomers' D between constructs") cat("\n############################\n\n") cat("Direction:", args$dependent, "are set as dependent\n") - if (col.index) # make index column for neater colnames - x <- addIndexColumnToMatrix(x) else - colnames(x) <- seq_len(ncol(x)) + if (col.index) { # make index column for neater colnames + x <- addIndexColumnToMatrix(x) + } else { + colnames(x) <- seq_len(ncol(x)) + } print(x) } @@ -741,74 +766,74 @@ print.constructD <- function(x, digits=1, col.index=TRUE, ...) #' #' @examples #' -#' constructPca(bell2010) +#' constructPca(bell2010) #' -#' # data from grid manual by Fransella et al. (2003, p. 87) -#' # note that the construct order is different -#' constructPca(fbb2003, nfactors=2) +#' # data from grid manual by Fransella et al. (2003, p. 87) +#' # note that the construct order is different +#' constructPca(fbb2003, nfactors = 2) #' -#' # no rotation -#' constructPca(fbb2003, rotate="none") +#' # no rotation +#' constructPca(fbb2003, rotate = "none") #' -#' # use a different type of correlation (Spearman) -#' constructPca(fbb2003, method="spearman") +#' # use a different type of correlation (Spearman) +#' constructPca(fbb2003, method = "spearman") #' -#' # save output to object -#' m <- constructPca(fbb2003, nfactors=2) -#' m +#' # save output to object +#' m <- constructPca(fbb2003, nfactors = 2) +#' m #' -#' # different printing options -#' print(m, digits=5) -#' print(m, cutoff=.3) -#' -constructPca <- function(x, nfactors=3, rotate="varimax", method = "pearson" , - trim=NA) { - - method <- match.arg(method,c("pearson", "kendall", "spearman")) +#' # different printing options +#' print(m, digits = 5) +#' print(m, cutoff = .3) +#' +constructPca <- function(x, nfactors = 3, rotate = "varimax", method = "pearson", + trim = NA) { + method <- match.arg(method, c("pearson", "kendall", "spearman")) rotate <- match.arg(rotate, c("none", "varimax", "promax", "cluster")) - if (!rotate %in% c("none", "varimax", "promax", "cluster")) + if (!rotate %in% c("none", "varimax", "promax", "cluster")) { stop('only "none", "varimax", "promax" and "cluster" are possible rotations') - - res <- constructCor(x, method=method, trim=trim) # calc inter constructs correations - pc <- principal(res, nfactors = nfactors, rotate=rotate) # do PCA + } + + res <- constructCor(x, method = method, trim = trim) # calc inter constructs correations + pc <- principal(res, nfactors = nfactors, rotate = rotate) # do PCA class(pc) <- c("constructPca", class(pc)) - attr(pc, "arguments") <- list(nfactors=nfactors, rotate=rotate, method=method) + attr(pc, "arguments") <- list(nfactors = nfactors, rotate = rotate, method = method) return(pc) } # TODO -constructPca_new <- function(x, nfactors = 3, method = "raw", rotate = "none", trim = NA) -{ - method <- match.arg(method,c("raw", "pearson", "kendall", "spearman")) - - # PCA of construct centered raw data +constructPca_new <- function(x, nfactors = 3, method = "raw", rotate = "none", trim = NA) { + method <- match.arg(method, c("raw", "pearson", "kendall", "spearman")) + + # PCA of construct centered raw data if (method == "raw") { input <- "matrix of construct centered raw data" - r <- ratings(x) - p <- stats::prcomp(t(r), center = TRUE, scale. = FALSE) + r <- ratings(x) + p <- stats::prcomp(t(r), center = TRUE, scale. = FALSE) eigenvalues <- p$sdev^2 load_mat <- p$rotation - } - + } + # PCA of construct correlations if (method != "raw") { input <- "construct correlation matrix" rotate <- match.arg(rotate, c("none", "varimax", "promax", "cluster")) - if (!rotate %in% c("none", "varimax", "promax", "cluster")) + if (!rotate %in% c("none", "varimax", "promax", "cluster")) { stop('only "none", "varimax", "promax" and "cluster" are possible rotations') - - res <- constructCor(x, method = method, trim = trim) # calc inter constructs correations - pc <- principal(res, nfactors = nfactors, rotate = rotate) # do PCA + } + + res <- constructCor(x, method = method, trim = trim) # calc inter constructs correations + pc <- principal(res, nfactors = nfactors, rotate = rotate) # do PCA class(pc) <- c("constructPca", class(pc)) - + load_mat <- loadings(pc) class(load_mat) <- "matrix" eigenvalues <- pc$values } - + # attr(pc, "arguments") <- list(nfactors = nfactors, rotate = rotate, method = method) return(pc) - # + # # # new structure # list( # input = input, @@ -817,12 +842,12 @@ constructPca_new <- function(x, nfactors = 3, method = "raw", rotate = "none", t # rotation = "none", # eigenvalues = eigenvalues, # loadings = load_mat - # - # + # + # # ) # scale(t(r))^2 %>% sum - # - # apply(load_mat, 2, function(x) sum(x^2)) + # + # apply(load_mat, 2, function(x) sum(x^2)) } @@ -833,18 +858,21 @@ constructPca_new <- function(x, nfactors = 3, method = "raw", rotate = "none", t #' @export #' @examples #' -#' p <- constructPca(bell2010) -#' l <- constructPcaLoadings(p) -#' l[1, ] -#' l[, 1] -#' l[1,1] -#' +#' p <- constructPca(bell2010) +#' l <- constructPcaLoadings(p) +#' l[1, ] +#' l[, 1] +#' l[1, 1] +#' constructPcaLoadings <- function(x) { - if (!inherits(x, "constructPca")) - stop("'x' must be an object of class 'constructPca'", - "as returned by the function 'constructPca'") - loadings(x) -} + if (!inherits(x, "constructPca")) { + stop( + "'x' must be an object of class 'constructPca'", + "as returned by the function 'constructPca'" + ) + } + loadings(x) +} #' Print method for class constructPca. @@ -856,18 +884,17 @@ constructPcaLoadings <- function(x) { #' @export #' @method print constructPca #' @keywords internal -#' -print.constructPca <- function(x, digits=2, cutoff=0, ...) -{ +#' +print.constructPca <- function(x, digits = 2, cutoff = 0, ...) { args <- attr(x, "arguments") - + cat("\n#################") cat("\nPCA of constructs") cat("\n#################\n") - + cat("\nNumber of components extracted:", args$nfactors) cat("\nType of rotation:", args$rotate, "\n") - print(loadings(x), cutoff=cutoff, digits=digits) + print(loadings(x), cutoff = cutoff, digits = digits) } @@ -910,86 +937,87 @@ print.constructPca <- function(x, digits=2, cutoff=0, ...) #' @seealso [alignByIdeal()] #' @examples #' -#' # reproduction of the example in the Bell (2010) -#' # constructs aligned by loadings on PC 1 -#' bell2010 -#' alignByLoadings(bell2010) -#' -#' # save results -#' a <- alignByLoadings(bell2010) -#' -#' # modify printing of resukts -#' print(a, digits=5) -#' -#' # access results for further processing -#' names(a) -#' a$cor.before -#' a$loadings.before -#' a$reversed -#' a$cor.after -#' a$loadings.after -#' -alignByLoadings <- function(x, trim=20, index=TRUE) { - options(warn=1) # suppress warnings (TODO sometimes error in SVD due to singularities in grid) - ccor.old <- constructCor(x, trim=trim, index=index) # construct correlation unreversed - pc.old <- principal(ccor.old) # calc principal component (psych pkg) - reverseIndex <- - which(pc.old$loadings[ ,1] < 0) # which constructs to reverse - x2 <- swapPoles(x, reverseIndex) # reverse constructs - ccor.new <- constructCor(x2, trim=trim, index=index) # correlation with reversed constructs - pc.new <- principal(ccor.new) # 2nd principal comps - options(warn=0) # reset to do warnings - - res <- list(cor.before=ccor.old, - loadings.before=pc.old$loadings[ , 1, drop=FALSE], - reversed=data.frame(index=reverseIndex), - cor.after=ccor.new, - loadings.after=pc.new$loadings[ , 1, drop=FALSE]) +#' # reproduction of the example in the Bell (2010) +#' # constructs aligned by loadings on PC 1 +#' bell2010 +#' alignByLoadings(bell2010) +#' +#' # save results +#' a <- alignByLoadings(bell2010) +#' +#' # modify printing of resukts +#' print(a, digits = 5) +#' +#' # access results for further processing +#' names(a) +#' a$cor.before +#' a$loadings.before +#' a$reversed +#' a$cor.after +#' a$loadings.after +#' +alignByLoadings <- function(x, trim = 20, index = TRUE) { + options(warn = 1) # suppress warnings (TODO sometimes error in SVD due to singularities in grid) + ccor.old <- constructCor(x, trim = trim, index = index) # construct correlation unreversed + pc.old <- principal(ccor.old) # calc principal component (psych pkg) + reverseIndex <- + which(pc.old$loadings[, 1] < 0) # which constructs to reverse + x2 <- swapPoles(x, reverseIndex) # reverse constructs + ccor.new <- constructCor(x2, trim = trim, index = index) # correlation with reversed constructs + pc.new <- principal(ccor.new) # 2nd principal comps + options(warn = 0) # reset to do warnings + + res <- list( + cor.before = ccor.old, + loadings.before = pc.old$loadings[, 1, drop = FALSE], + reversed = data.frame(index = reverseIndex), + cor.after = ccor.new, + loadings.after = pc.new$loadings[, 1, drop = FALSE] + ) class(res) <- "alignByLoadings" res } #' Print method for class alignByLoadings. -#' +#' #' @param x Object of class alignByLoadings. -#' @param digits Numeric. Number of digits to round to (default is +#' @param digits Numeric. Number of digits to round to (default is #' `2`). -#' @param col.index Logical. Whether to add an extra index column so the -#' column names are indexes instead of construct names (e.g. for -#' the correlation matrices). This option -#' renders a neater output as long construct names will stretch +#' @param col.index Logical. Whether to add an extra index column so the +#' column names are indexes instead of construct names (e.g. for +#' the correlation matrices). This option +#' renders a neater output as long construct names will stretch #' the output (default is `TRUE`). #' @param ... Not evaluated. #' @export #' @method print alignByLoadings #' @keywords internal #' -print.alignByLoadings <- function(x, digits=2, col.index=TRUE, ...) -{ - cat("\n###################################") - cat("\nAlignment of constructs by loadings") - cat("\n###################################\n") - - cat("\nConstruct correlations - before alignment\n\n") - print(x$cor.before, digits=digits, col.index=col.index, header=FALSE) - - cat("\nConstruct factor loadiongs on PC1 - before alignment\n\n") - print(x$loadings.before, digits=digits) - - cat("\nThe following constructs are reversed:\n\n") - if (dim(x$reversed)[1] == 0) { - cat("None. All constructs are already aligned accordingly.\n") - } else { - print(x$reversed) - } - - cat("\nConstruct correlations - after alignment\n\n") - print(x$cor.after, digits=digits, col.index=col.index, header=FALSE) - - cat("\nConstruct factor loadings on PC1 - after alignment\n\n") - print(x$loadings.after, digits=digits) - cat("\n\n") +print.alignByLoadings <- function(x, digits = 2, col.index = TRUE, ...) { + cat("\n###################################") + cat("\nAlignment of constructs by loadings") + cat("\n###################################\n") + + cat("\nConstruct correlations - before alignment\n\n") + print(x$cor.before, digits = digits, col.index = col.index, header = FALSE) + + cat("\nConstruct factor loadiongs on PC1 - before alignment\n\n") + print(x$loadings.before, digits = digits) + + cat("\nThe following constructs are reversed:\n\n") + if (dim(x$reversed)[1] == 0) { + cat("None. All constructs are already aligned accordingly.\n") + } else { + print(x$reversed) + } + + cat("\nConstruct correlations - after alignment\n\n") + print(x$cor.after, digits = digits, col.index = col.index, header = FALSE) + + cat("\nConstruct factor loadings on PC1 - after alignment\n\n") + print(x$loadings.after, digits = digits) + cat("\n\n") } @@ -1022,30 +1050,36 @@ print.alignByLoadings <- function(x, digits=2, col.index=TRUE, ...) #' #' @export #' @seealso [alignByLoadings()] -#' @examples -#' -#' feixas2004 # original grid -#' alignByIdeal(feixas2004, 13) # aligned with preference pole on the right -#' -#' raeithel # original grid -#' alignByIdeal(raeithel, 3, high=FALSE) # aligned with preference pole on the left -#' -alignByIdeal <- function(x, ideal, high=TRUE){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - +#' @examples +#' +#' feixas2004 # original grid +#' alignByIdeal(feixas2004, 13) # aligned with preference pole on the right +#' +#' raeithel # original grid +#' alignByIdeal(raeithel, 3, high = FALSE) # aligned with preference pole on the left +#' +alignByIdeal <- function(x, ideal, high = TRUE) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + idealRatings <- getRatingLayer(x)[, ideal] unclear <- which(idealRatings == getScaleMidpoint(x)) positive <- which(idealRatings > getScaleMidpoint(x)) negative <- which(idealRatings < getScaleMidpoint(x)) - - if (high) - x <- swapPoles(x, negative) else # align such that ratings on ideal are high - x <- swapPoles(x, positive) # align such that ratings on ideal are low - - if (length(unclear) != 0) - warning("The following constructs do not show a preference for either pole", - "and have thus not been aligned: ", paste(unclear, collapse=",")) + + if (high) { + x <- swapPoles(x, negative) + } else { # align such that ratings on ideal are high + x <- swapPoles(x, positive) + } # align such that ratings on ideal are low + + if (length(unclear) != 0) { + warning( + "The following constructs do not show a preference for either pole", + "and have thus not been aligned: ", paste(unclear, collapse = ",") + ) + } x } @@ -1094,78 +1128,90 @@ alignByIdeal <- function(x, ideal, high=TRUE){ #' @seealso [bertinCluster()] #' @examples #' -#' cluster(bell2010) -#' cluster(bell2010, main="My cluster analysis") # new title -#' cluster(bell2010, type="t") # different drawing style -#' cluster(bell2010, dmethod="manhattan") # using manhattan metric -#' cluster(bell2010, cmethod="single") # do single linkage clustering -#' cluster(bell2010, cex=1, lab.cex=1) # change appearance -#' cluster(bell2010, lab.cex=.7, edgePar=list(lty=1:2, col=2:1)) # advanced appearance changes -#' -cluster <- function(x, along=0, dmethod="euclidean", cmethod="ward.D", p=2, - align=TRUE, trim=NA, main=NULL, - mar=c(4, 2, 3, 15), cex=0, lab.cex=.8, cex.main=.9, - print=TRUE, ...) { +#' cluster(bell2010) +#' cluster(bell2010, main = "My cluster analysis") # new title +#' cluster(bell2010, type = "t") # different drawing style +#' cluster(bell2010, dmethod = "manhattan") # using manhattan metric +#' cluster(bell2010, cmethod = "single") # do single linkage clustering +#' cluster(bell2010, cex = 1, lab.cex = 1) # change appearance +#' cluster(bell2010, lab.cex = .7, edgePar = list(lty = 1:2, col = 2:1)) # advanced appearance changes +#' +cluster <- function(x, along = 0, dmethod = "euclidean", cmethod = "ward.D", p = 2, + align = TRUE, trim = NA, main = NULL, + mar = c(4, 2, 3, 15), cex = 0, lab.cex = .8, cex.main = .9, + print = TRUE, ...) { dmethods <- c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski") dmethod <- match.arg(dmethod, dmethods) - + cmethods <- c("ward.D", "ward.D2", "single", "complete", "average", "mcquitty", "median", "centroid") cmethod <- match.arg(cmethod, cmethods) - - if (is.null(main)) + + if (is.null(main)) { main <- paste(dmethod, "distance and", cmethod, "clustering") - if (! along %in% 0:2) + } + if (!along %in% 0:2) { stop("'along must take the value 0, 1 or 2.") - if (align) - x <- align(x, along = along, dmethod = dmethod, - cmethod = cmethod, p = p) - r <- getRatingLayer(x, trim=trim) # get ratings + } + if (align) { + x <- align(x, + along = along, dmethod = dmethod, + cmethod = cmethod, p = p + ) + } + r <- getRatingLayer(x, trim = trim) # get ratings # dendrogram for constructs - if (along %in% 0:1){ - d <- dist(r, method = dmethod, p=p) # make distance matrix for constructs - fit.constructs <- hclust(d, method=cmethod) # hclust object for constructs + if (along %in% 0:1) { + d <- dist(r, method = dmethod, p = p) # make distance matrix for constructs + fit.constructs <- hclust(d, method = cmethod) # hclust object for constructs dend.con <- as.dendrogram(fit.constructs) con.ord <- order.dendrogram(rev(dend.con)) - x <- x[con.ord, ] # reorder repgrid object + x <- x[con.ord, ] # reorder repgrid object } - - if (along %in% c(0,2)){ + + if (along %in% c(0, 2)) { # dendrogram for elements - d <- dist(t(r), method = dmethod, p=p) # make distance matrix for elements - fit.elements <- hclust(d, method=cmethod) # hclust object for elements + d <- dist(t(r), method = dmethod, p = p) # make distance matrix for elements + fit.elements <- hclust(d, method = cmethod) # hclust object for elements dend.el <- as.dendrogram(fit.elements) el.ord <- order.dendrogram(dend.el) - x <- x[ , el.ord] # reorder repgrid object + x <- x[, el.ord] # reorder repgrid object } - - if (print){ # print dendrogram? - op <- par(mar=mar) # change mar settings and save old mar settings - if (along == 0) - layout(matrix(1:2, ncol=1)) - if (along %in% c(0,1)){ - plot(dend.con, horiz=TRUE, main=main, xlab="", # print cluster solution - nodePar=list(cex=cex, lab.cex=lab.cex), - cex.main=cex.main, ...) + + if (print) { # print dendrogram? + op <- par(mar = mar) # change mar settings and save old mar settings + if (along == 0) { + layout(matrix(1:2, ncol = 1)) + } + if (along %in% c(0, 1)) { + plot(dend.con, + horiz = TRUE, main = main, xlab = "", # print cluster solution + nodePar = list(cex = cex, lab.cex = lab.cex), + cex.main = cex.main, ... + ) } - if (along %in% c(0,2)){ - plot(dend.el, horiz=TRUE, main=main, xlab="", # print cluster solution - nodePar=list(cex=cex, lab.cex=lab.cex), - cex.main=cex.main, ...) - } - par(op) # reset to old mar settings + if (along %in% c(0, 2)) { + plot(dend.el, + horiz = TRUE, main = main, xlab = "", # print cluster solution + nodePar = list(cex = cex, lab.cex = lab.cex), + cex.main = cex.main, ... + ) + } + par(op) # reset to old mar settings } - invisible(x) # return reordered repgrid object + invisible(x) # return reordered repgrid object } # function calculates cluster dendrogram from doublebind grid matrix # and reverses the constructs accoring to the upper big cluster -align <- function(x, along = 0, dmethod = "euclidean", +align <- function(x, along = 0, dmethod = "euclidean", cmethod = "ward.D", p = 2, ...) { x2 <- doubleEntry(x) - xr <- cluster(x2, dmethod=dmethod, cmethod=cmethod, p=p, - align=FALSE, print=FALSE) + xr <- cluster(x2, + dmethod = dmethod, cmethod = cmethod, p = p, + align = FALSE, print = FALSE + ) nc <- getNoOfConstructs(xr) / 2 xr[1:nc, ] } @@ -1196,39 +1242,39 @@ align <- function(x, along = 0, dmethod = "euclidean", #' second step the direction of a construct that yields smaller distances to the adjacent constructs is preserved and #' used for the final clustering. As a result, every construct is included once but with an orientation that guarantees #' optimal clustering. This approach is akin to the procedure used in FOCUS (Jankowicz & Thomas, 1982). -#' -#' @references -#' -#' Felsenstein, J. (1985). Confidence Limits on Phylogenies: An Approach Using +#' +#' @references +#' +#' Felsenstein, J. (1985). Confidence Limits on Phylogenies: An Approach Using #' the Bootstrap. *Evolution, 39*(4), 783. doi:10.2307/2408678 -#' +#' #' Hillis, D. M., & Bull, J. J. (1993). An Empirical Test of Bootstrapping as a #' Method for Assessing Confidence in Phylogenetic Analysis. *Systematic Biology, #' 42*(2), 182-192. -#' -#' Jankowicz, D., & Thomas, L. (1982). An Algorithm for the Cluster Analysis of +#' +#' Jankowicz, D., & Thomas, L. (1982). An Algorithm for the Cluster Analysis of #' Repertory Grids in Human Resource Development. *Personnel Review, #' 11*(4), 15-22. doi:10.1108/eb055464. -#' +#' #' Shimodaira, H. (2002) An approximately unbiased test of phylogenetic tree #' selection. *Syst, Biol., 51*, 492-508. -#' +#' #' Shimodaira,H. (2004) Approximately unbiased tests of regions using multistep- #' multiscale bootstrap resampling. *Ann. Stat., 32*, 2616-2614. -#' +#' #' Suzuki, R., & Shimodaira, H. (2006). Pvclust: an R package for assessing the #' uncertainty in hierarchical clustering. *Bioinformatics, #' 22*(12), 1540-1542. doi:10.1093/bioinformatics/btl117 -#' +#' #' Zharkikh, A., & Li, W.-H. (1995). Estimation of confidence in phylogeny: the #' complete-and-partial bootstrap technique. *Molecular Phylogenetic Evolution, -#' 4*(1), 44-63. -#' +#' 4*(1), 44-63. +#' #' @param x `grid object` #' @param align Whether the constructs should be aligned before clustering -#' (default is `TRUE`). If not, the grid matrix is clustered +#' (default is `TRUE`). If not, the grid matrix is clustered #' as is. See Details section for more information. -#' @param along Along which dimension to cluster. 1 = constructs, 2= elements. +#' @param along Along which dimension to cluster. 1 = constructs, 2= elements. #' @inheritParams cluster #' @param p Power of the Minkowski metric. Not yet passed on to pvclust! #' @inheritParams pvclust::pvclust @@ -1239,38 +1285,41 @@ align <- function(x, along = 0, dmethod = "euclidean", #' @export #' @examples \dontrun{ #' -#' # pvclust must be loaded -#' library(pvclust) -#' -#' # p-values for construct dendrogram -#' s <- clusterBoot(boeker) -#' plot(s) -#' pvrect(s, max.only=FALSE) -#' -#' # p-values for element dendrogram -#' s <- clusterBoot(boeker, along=2) -#' plot(s) -#' pvrect(s, max.only=FALSE) +#' # pvclust must be loaded +#' library(pvclust) +#' +#' # p-values for construct dendrogram +#' s <- clusterBoot(boeker) +#' plot(s) +#' pvrect(s, max.only = FALSE) +#' +#' # p-values for element dendrogram +#' s <- clusterBoot(boeker, along = 2) +#' plot(s) +#' pvrect(s, max.only = FALSE) #' } #' -clusterBoot <- function(x, along=1, align=TRUE, dmethod = "euclidean", - cmethod = "ward.D", p=2, nboot=1000, - r=seq(.8, 1.4, by=.1), seed=NULL, ...) -{ - if (! along %in% 1:2) - stop("along must either be 1 for constructs (default) or 2 for element clustering", call.=FALSE) - if (align) +clusterBoot <- function(x, along = 1, align = TRUE, dmethod = "euclidean", + cmethod = "ward.D", p = 2, nboot = 1000, + r = seq(.8, 1.4, by = .1), seed = NULL, ...) { + if (!along %in% 1:2) { + stop("along must either be 1 for constructs (default) or 2 for element clustering", call. = FALSE) + } + if (align) { x <- align(x) + } xr <- getRatingLayer(x) - if (!is.null(seed) & is.numeric(seed)) - set.seed(seed) - if (along ==1) - xr <- t(xr) - pv.e <- pvclust::pvclust(xr, method.hclust=cmethod, method.dist=dmethod, r=r, nboot=nboot, ...) + if (!is.null(seed) & is.numeric(seed)) { + set.seed(seed) + } + if (along == 1) { + xr <- t(xr) + } + pv.e <- pvclust::pvclust(xr, method.hclust = cmethod, method.dist = dmethod, r = r, nboot = nboot, ...) pv.e } -#' Normalize rows or columns by its standard deviation. +#' Normalize rows or columns by its standard deviation. #' #' @param x `matrix` #' @param normalize A numeric value indicating along what direction (rows, columns) @@ -1279,23 +1328,26 @@ clusterBoot <- function(x, along=1, align=TRUE, dmethod = "euclidean", #' @param ... Not evaluated. #' @return Not yet defined TODO! #' @export -#' @examples -#' x <- matrix(sample(1:5, 20, rep=TRUE), 4) -#' normalize(x, 1) # normalizing rows -#' normalize(x, 2) # normalizing columns -#' -normalize <- function(x, normalize=0, ...){ - if (!normalize %in% 0:2 ) - stop("along must take a numeric value:\n", - "normalize, 0 = none, 1 = rows, 2=columns") - if (normalize == 1){ - x <- t(x) - x <- scale(x, center=FALSE, scale=apply(x, 2, sd, na.rm=TRUE)) # see ? scale +#' @examples +#' x <- matrix(sample(1:5, 20, rep = TRUE), 4) +#' normalize(x, 1) # normalizing rows +#' normalize(x, 2) # normalizing columns +#' +normalize <- function(x, normalize = 0, ...) { + if (!normalize %in% 0:2) { + stop( + "along must take a numeric value:\n", + "normalize, 0 = none, 1 = rows, 2=columns" + ) + } + if (normalize == 1) { + x <- t(x) + x <- scale(x, center = FALSE, scale = apply(x, 2, sd, na.rm = TRUE)) # see ? scale x <- t(x) - } else if (normalize == 2){ - x <- scale(x, center=FALSE, scale=apply(x, 2, sd, na.rm=TRUE)) # see ? scale + } else if (normalize == 2) { + x <- scale(x, center = FALSE, scale = apply(x, 2, sd, na.rm = TRUE)) # see ? scale } - x + x } @@ -1313,26 +1365,30 @@ normalize <- function(x, normalize=0, ...){ #' attach to the centered values. #' @export #' @examples -#' center(bell2010) # no centering -#' center(bell2010, rows=T) # row centering of grid -#' center(bell2010, cols=T) # column centering of grid -#' center(bell2010, rows=T, cols=T) # row and column centering -#' -center <- function(x, center=1, ...) { - dat <- x@ratings[ , ,1] - if (center == 0) # no centering - res <- dat - if (center == 1) # center at row (construct) mean - res <- sweep(dat, 1, apply(dat, 1, mean, na.rm=TRUE)) - if (center == 2) # center at column (element) mean - res <- sweep(dat, 2, apply(dat, 2, mean, na.rm=TRUE)) - if (center == 3){ # center at row and column mean - res <- sweep(dat, 1, apply(dat, 1, mean, na.rm=TRUE)) - res <- sweep(res, 2, apply(res, 2, mean, na.rm=TRUE)) +#' center(bell2010) # no centering +#' center(bell2010, rows = T) # row centering of grid +#' center(bell2010, cols = T) # column centering of grid +#' center(bell2010, rows = T, cols = T) # row and column centering +#' +center <- function(x, center = 1, ...) { + dat <- x@ratings[, , 1] + if (center == 0) { # no centering + res <- dat + } + if (center == 1) { # center at row (construct) mean + res <- sweep(dat, 1, apply(dat, 1, mean, na.rm = TRUE)) + } + if (center == 2) { # center at column (element) mean + res <- sweep(dat, 2, apply(dat, 2, mean, na.rm = TRUE)) + } + if (center == 3) { # center at row and column mean + res <- sweep(dat, 1, apply(dat, 1, mean, na.rm = TRUE)) + res <- sweep(res, 2, apply(res, 2, mean, na.rm = TRUE)) + } + if (center == 4) { # center at midpoint i.e. middle of scale + res <- dat - getScaleMidpoint(x) } - if (center == 4) # center at midpoint i.e. middle of scale - res <- dat - getScaleMidpoint(x) - res + res } @@ -1372,70 +1428,73 @@ center <- function(x, center=1, ...) { #' @export #' @examples #' -#' # explained sum-of-squares for elements -#' ssq(bell2010) -#' -#' # explained sum-of-squares for constructs -#' ssq(bell2010, along=1) -#' -#' # save results -#' s <- ssq(bell2010) -#' -#' # printing options -#' print(s) -#' print(s, digits=4) -#' print(s, dim=3) -#' print(s, cumulated=FALSE) -#' -#' # access results -#' names(s) -#' s$ssq.table -#' s$ssq.table.cumsum -#' s$ssq.total -#' -ssq <- function(x, along=2, center=1, normalize=0, - g=0, h=1-g, col.active=NA, col.passive=NA, ...){ - x <- calcBiplotCoords(x, center=center, normalize=normalize, - g=g, h=h, col.active= col.active, - col.passive=col.passive) - if (is.null(x@calcs$biplot)) +#' # explained sum-of-squares for elements +#' ssq(bell2010) +#' +#' # explained sum-of-squares for constructs +#' ssq(bell2010, along = 1) +#' +#' # save results +#' s <- ssq(bell2010) +#' +#' # printing options +#' print(s) +#' print(s, digits = 4) +#' print(s, dim = 3) +#' print(s, cumulated = FALSE) +#' +#' # access results +#' names(s) +#' s$ssq.table +#' s$ssq.table.cumsum +#' s$ssq.total +#' +ssq <- function(x, along = 2, center = 1, normalize = 0, + g = 0, h = 1 - g, col.active = NA, col.passive = NA, ...) { + x <- calcBiplotCoords(x, + center = center, normalize = normalize, + g = g, h = h, col.active = col.active, + col.passive = col.passive + ) + if (is.null(x@calcs$biplot)) { stop("biplot coordinates have not yet been calculated") - + } + E <- x@calcs$biplot$el C <- x@calcs$biplot$con X <- x@calcs$biplot$X - + enames <- elements(x) cnames <- constructs(x)$rightpole - - ssq.c <- diag(X %*% t(X)) # SSQ for each row (constructs) - ssq.e <- diag(t(X) %*% X) # SSQ for each column(element) - ssq.c.prop <- C^2 / ssq.c # ssq of row and dimension / total ssq element - ssq.e.prop <- E^2 / ssq.e # ssq of element and dimension / total ssq element - - rownames(ssq.c.prop) <- cnames # add construct names to rows - colnames(ssq.c.prop) <- # add dimension labels to columns - paste(1L:ncol(ssq.c.prop), "D", sep="") - rownames(ssq.e.prop) <- enames # add element names to rows - colnames(ssq.e.prop) <- # add dimension labels to columns - paste(1L:ncol(ssq.e.prop), "D", sep="") - - ssq.c.cumsum <- t(apply(ssq.c.prop, 1, cumsum)) # cumulated ssq of construct per dimension / total ssq element - ssq.e.cumsum <- t(apply(ssq.e.prop, 1, cumsum)) # cumulated ssq of elements per dimension / total ssq element - ssq.c.avg <- apply(C^2, 2, sum, na.rm=T) / sum(ssq.c) # ssq per dimension / ssq total - ssq.e.avg <- apply(E^2, 2, sum, na.rm=T) / sum(ssq.e) # ssq per dimension / ssq total - ssq.c.avg.cumsum <- cumsum(ssq.c.avg) # cumulated ssq per dimension / ssq total - ssq.e.avg.cumsum <- cumsum(ssq.e.avg) # cumulated ssq per dimension / ssq total - ssq.c.table <- rbind(ssq.c.prop, TOTAL=ssq.c.avg) # - ssq.e.table <- rbind(ssq.e.prop, TOTAL=ssq.e.avg) # - ssq.c.table.cumsum <- rbind(ssq.c.cumsum, TOTAL=ssq.c.avg.cumsum) - ssq.e.table.cumsum <- rbind(ssq.e.cumsum, TOTAL=ssq.e.avg.cumsum) + + ssq.c <- diag(X %*% t(X)) # SSQ for each row (constructs) + ssq.e <- diag(t(X) %*% X) # SSQ for each column(element) + ssq.c.prop <- C^2 / ssq.c # ssq of row and dimension / total ssq element + ssq.e.prop <- E^2 / ssq.e # ssq of element and dimension / total ssq element + + rownames(ssq.c.prop) <- cnames # add construct names to rows + colnames(ssq.c.prop) <- # add dimension labels to columns + paste(1L:ncol(ssq.c.prop), "D", sep = "") + rownames(ssq.e.prop) <- enames # add element names to rows + colnames(ssq.e.prop) <- # add dimension labels to columns + paste(1L:ncol(ssq.e.prop), "D", sep = "") + + ssq.c.cumsum <- t(apply(ssq.c.prop, 1, cumsum)) # cumulated ssq of construct per dimension / total ssq element + ssq.e.cumsum <- t(apply(ssq.e.prop, 1, cumsum)) # cumulated ssq of elements per dimension / total ssq element + ssq.c.avg <- apply(C^2, 2, sum, na.rm = T) / sum(ssq.c) # ssq per dimension / ssq total + ssq.e.avg <- apply(E^2, 2, sum, na.rm = T) / sum(ssq.e) # ssq per dimension / ssq total + ssq.c.avg.cumsum <- cumsum(ssq.c.avg) # cumulated ssq per dimension / ssq total + ssq.e.avg.cumsum <- cumsum(ssq.e.avg) # cumulated ssq per dimension / ssq total + ssq.c.table <- rbind(ssq.c.prop, TOTAL = ssq.c.avg) # + ssq.e.table <- rbind(ssq.e.prop, TOTAL = ssq.e.avg) # + ssq.c.table.cumsum <- rbind(ssq.c.cumsum, TOTAL = ssq.c.avg.cumsum) + ssq.e.table.cumsum <- rbind(ssq.e.cumsum, TOTAL = ssq.e.avg.cumsum) ssq.c.table <- ssq.c.table * 100 ssq.e.table <- ssq.e.table * 100 ssq.c.table.cumsum <- ssq.c.table.cumsum * 100 ssq.e.table.cumsum <- ssq.e.table.cumsum * 100 - - if (along == 1){ # elements or constructs? + + if (along == 1) { # elements or constructs? ssq.table <- ssq.c.table ssq.table.cumsum <- ssq.c.table.cumsum along.text <- "constructs" @@ -1444,49 +1503,56 @@ ssq <- function(x, along=2, center=1, normalize=0, ssq.table.cumsum <- ssq.e.table.cumsum along.text <- "elements" } - - l <- list(ssq.table=ssq.table, - ssq.table.cumsum=ssq.table.cumsum, - ssq.total=sum(ssq.e)) - attr(l, "arguments") <- list(along.text=along.text) + + l <- list( + ssq.table = ssq.table, + ssq.table.cumsum = ssq.table.cumsum, + ssq.total = sum(ssq.e) + ) + attr(l, "arguments") <- list(along.text = along.text) class(l) <- "ssq" - return(l) + return(l) } #' Print method for class ssq. -#' +#' #' @param x Object of class ssq. #' @param digits Number of digits to round the output to (default is `2`). #' @param dim The number of PCA dimensions to print. Default -#' is `5` dimensions. `NA` will print all +#' is `5` dimensions. `NA` will print all #' dimensions. -#' @param cumulated Logical (default is `TRUE`). +#' @param cumulated Logical (default is `TRUE`). #' Print a cumulated table of sum-of-squares? -#' If `FALSE` the non-cumulated sum-of-squares are printed. +#' If `FALSE` the non-cumulated sum-of-squares are printed. #' (default is `TRUE`). #' @param ... Not evaluated. #' @export #' @method print ssq #' @keywords internal #' -print.ssq <- function(x, digits=2, dim=5, cumulated=TRUE, ...) { +print.ssq <- function(x, digits = 2, dim = 5, cumulated = TRUE, ...) { # dimensions to print - if (is.na(dim[1])) + if (is.na(dim[1])) { dim <- ncol(x$ssq.table) + } args <- attr(x, "arguments") - if (cumulated) { # output cumulated table? - ssq.out <- x$ssq.table.cumsum + if (cumulated) { # output cumulated table? + ssq.out <- x$ssq.table.cumsum cum.text <- "Cumulated proportion" } else { - ssq.out <- x$ssq.table + ssq.out <- x$ssq.table cum.text <- "Proportion" } - cat("\n", cum.text, "of explained sum-of-squares for ", - args$along.text, "\n\n", sep="") + cat("\n", cum.text, "of explained sum-of-squares for ", + args$along.text, "\n\n", + sep = "" + ) print(round(ssq.out[, 1:dim], digits)) - cat("\nTotal sum-of-squares of pre-transformed ", - "(i.e. centered and scaled) matrix:", x$ssq.total) + cat( + "\nTotal sum-of-squares of pre-transformed ", + "(i.e. centered and scaled) matrix:", x$ssq.total + ) } @@ -1529,11 +1595,12 @@ print.ssq <- function(x, digits=2, dim=5, cumulated=TRUE, ...) { #' @seealso [indexUncertainty] #' #' @export -indexDDI <- function(x, ds) { +indexDDI <- function(x, ds) { stop_if_not_is_repgrid(x) stop_if_not_0_1_ratings_only(x) - if (any(ds < 1)) + if (any(ds < 1)) { stop("'ds' must be a vector of positive integer values", call. = FALSE) + } .indexDDIvec(x, ds) } @@ -1542,9 +1609,9 @@ indexDDI <- function(x, ds) { # k: number of people (columns) in grid # N: total number of dependencies in grid # n_i: number of dependencies involving person i (= number of ticks in column) -.indexDDI <- function(x, DS) { +.indexDDI <- function(x, DS) { r <- ratings(x) - N <- sum(r == 1) + N <- sum(r == 1) n_i <- colSums(r) DI <- sum(1 - choose(N - n_i, DS) / choose(N, DS)) return(DI) @@ -1576,13 +1643,13 @@ indexDDI <- function(x, ds) { #' @seealso [indexDDI] #' #' @export -indexUncertainty <- function(x) { +indexUncertainty <- function(x) { stop_if_not_is_repgrid(x) stop_if_not_0_1_ratings_only(x) # # formula Bell (2001, p. 228): # - # Log(total dependencies) – [Sum (dependencies by resource) × Log (dependencies by resource)] / + # Log(total dependencies) – [Sum (dependencies by resource) × Log (dependencies by resource)] / # (total dependencies) # maximum, with k = number of resources (columns): # @@ -1590,12 +1657,12 @@ indexUncertainty <- function(x) { # r <- ratings(x) dep_total <- sum(r) - dep_per_column <- colSums(r) + dep_per_column <- colSums(r) value <- log(dep_total) - sum(dep_per_column * log(dep_per_column)) / dep_total - + k <- ncol(x) maximum <- log(dep_total) - log(dep_total / k) - + res <- value / maximum names(res) <- "Uncertainty Index" return(res) diff --git a/R/data-openrepgrid.r b/R/data-openrepgrid.r index 07b9a83e..69726a0f 100644 --- a/R/data-openrepgrid.r +++ b/R/data-openrepgrid.r @@ -1,600 +1,589 @@ -#////////////////////////////////////////////////////////////////////////////// -# -# data that comes along with the OpenRepGrid package -# -#////////////////////////////////////////////////////////////////////////////// - - -#////////////////////////////////////////////////////////////////////////////// - -#' Grid data from Bell (2010). -#' -#' Grid data originated (but is not shown in the paper) from a study by Haritos, -#' Gindinis, Doan and Bell (2004) on element role titles. It was used to -#' demonstrate the effects of construct alignment in Bell (2010, p. 46). -#' -#' @name data-bell2010 -#' @aliases bell2010 -#' @docType data -#' @references Bell, R. C. (2010). A note on aligning constructs. -#' *Personal Construct Theory and Practice*, 7, 43-48. -#' -#' Haritos, A., Gindidis, A., Doan, C., & Bell, R. C. (2004). -#' The effect of element role titles on construct structure -#' and content. *Journal of constructivist -#' psychology, 17*(3), 221-236. -#' -#' @keywords data -#' -NULL - -# args <- list( -# name=c( "self", "closest friend of the same sex", "the unhappiest person you know", -# "A person of the opposite sex that you don't get along with", -# "A teacher you respected", -# "Mother (or the person who filled that kind of role)", -# "A person of the opposite sex that you like more than you dislike", -# "The most confident person you know", -# "A person you work well with (at job or on sports team etc)", -# "A teacher you did not respect"), -# l.name=c( "relaxed", "not so smart (academically)", "dislikes sports", -# "not interactive", "not transparent", "insensitive", "fearful&timid", -# "rough", "accept as it is"), -# r.name=c( "worried & tense", "smart (academically)", "loves sports", -# "loves people", "transparent", "sensitive", "fearless", "gentle", -# "loves to argue"), -# scores= c(4,4,6,5,3,6,5,2,2,6, -# 6,7,6,5,7,4,6,7,4,7, -# 6,3,7,6,4,4,2,3,6,3, -# 6,7,5,6,6,5,6,7,7,4, -# 6,4,5,7,3,7,6,5,6,3, -# 4,6,5,4,4,6,5,3,4,2, -# 5,4,4,6,5,3,5,6,5,5, -# 5,6,6,4,5,7,7,3,5,6, -# 5,5,6,7,4,4,6,7,5,5) -# ) -# bell2010 <- makeRepgrid(args) -# bell2010 <- setScale(bell2010, 1, 7) -# save("bell2010", file="../data/bell2010.RData") - - -#////////////////////////////////////////////////////////////////////////////// - -#' Grid data from Bell and McGorry (1992). -#' -#' The grid data set is used in Bell's technical report "Using SPSS to Analyse -#' Repertory Grid Data" (1997, p. 6). Originally, the data comes from a study -#' by Bell and McGorry (1992). -#' -#' @name data-bellmcgorry1992 -#' @aliases bellmcgorry1992 -#' @docType data -#' @references Bell, R. C. (1977). *Using SPSS to -#' Analyse Repertory Grid Data*. Technical Report, -#' University of Melbourne. -#' -#' Bell, R. C., & McGorry, P. (1992). The analysis of repertory -#' grids used to monitor the perceptions of recovering psychotic -#' patients. In A. Thomson & P. Cummins (Eds.), *European Perspectives -#' in Personal Construct Psychology* (p. 137-150). -#' Lincoln, UK: European Personal Construct Association. -#' -#' @keywords data -#' -NULL - - -# abbreviations not yet included -# c("bipolar", "schiz", "psychiat", "criminal", "average", -# "aids", "diabetes", "cancer", "stress", "usualme", "menow", -# "meth", "staffme", "idealme", "conlab") -# args <- list( -# name= c('person with manic depressive illness', 'person with schizophrenia', -# 'psychiatric patient','convicted criminal','average person', -# 'AIDS patient','person with diabetes','person with cancer', -# 'person under stress','myself as I usually am','myself as I am now', -# 'myself as I will be in six months','myself as the staff see me', -# 'my ideal self'), -# l.name=c("good", "dependable", "safe", "clearheaded", "stable", -# "predictable", "intelligent", "free", "healthy", "honest", -# "rational", "independent", "calm", "understood"), -# r.name=rep("", 14), -# scores =c(3,5,3,7,4,2,1,1,7,1,1,1,2,1, -# 4,5,4,7,3,3,1,2,7,2,1,1,3,1, -# 6,7,4,7,3,7,1,2,6,1,1,1,2,1, -# 7,7,4,7,2,7,2,4,7,1,1,1,2,1, -# 7,7,5,7,2,7,1,4,7,2,2,1,3,1, -# 7,7,5,7,6,5,4,4,7,7,7,3,7,7, -# 4,5,4,7,2,1,2,2,7,1,1,1,2,1, -# 7,7,5,7,1,7,1,1,1,1,7,1,7,1, -# 6,7,4,7,1,7,7,7,7,1,4,1,4,1, -# 5,5,4,7,1,1,3,4,4,1,1,1,3,1, -# 5,7,5,6,1,2,2,4,5,1,1,1,3,1, -# 5,6,5,7,1,5,3,4,5,1,1,1,2,1, -# 6,5,5,7,2,7,3,4,7,1,1,1,1,1, -# 6,7,6,7,1,7,3,4,7,3,7,1,7,1) -# ) -# -# bellmcgorry1992 <- makeRepgrid(args) -# bellmcgorry1992 <- setScale(bellmcgorry1992, 1, 7) -# save("bellmcgorry1992", file="../data/bellmcgorry1992.RData") - - -#////////////////////////////////////////////////////////////////////////////// - -#' Grid data from Boeker (1996). -#' -#' Grid data from a schizophrenic patient undergoing psychoanalytically -#' oriented psychotherapy. The data was taken during the last stage of -#' therapy (Boeker, 1996, p. 163). -#' -#' @name data-boeker -#' @aliases boeker -#' @docType data -#' @references Boeker, H. (1996). The reconstruction of the self in -#' the psychotherapy of chronic schizophrenia: a case study -#' with the Repertory Grid Technique. In: Scheer, J. W., -#' Catina, A. (Eds.): *Empirical Constructivism in Europe - -#' The Personal Construct Approach* (p. 160-167). -#' Giessen: Psychosozial-Verlag. -#' -#' @keywords data -NULL - -# Heinz Boeker in Scheer & Catina (1996, p.163) -# scale used: 1 to 6 - -# args <- list( -# name=c("self", "ideal self", "mother", "father", "kurt", "karl", -# "george", "martin", "elizabeth", "therapist", "irene", -# "childhood self", "self before illness", "self with delusion" , -# "self as dreamer"), -# l.name=c("balanced", "isolated", "closely integrated", "discursive", -# "open minded", "dreamy", "practically oriented", "playful", -# "socially minded", "quarrelsome", "artistic", "scientific", -# "introvert", "wanderlust"), -# r.name=c("get along with conflicts", "sociable", "excluded", "passive", -# "indifferent", "dispassionate", "depressed", "serious", -# "selfish", "peaceful", "technical", "emotional", -# "extrovert", "home oriented"), -# scores= c(1, 4, 2, 2, 3, 5, 2, 5, 4, 2, 6, 2, 2, 3, 3, -# 3, 6, 3, 5, 5, 4, 5, 4, 5, 4, 4, 4, 2, 2, 3, -# 2, 2, 2, 3, 5, 3, 2, 3, 2, 3, 3, 4, 4, 5, 3, -# 4, 1, 3, 1, 2, 4, 2, 3, 3, 2, 3, 3, 3, 5, 4, -# 2, 1, 2, 1, 2, 4, 4, 2, 4, 2, 6, 3, 2, 2, 3, -# 4, 5, 3, 5, 4, 5, 4, 5, 4, 4, 6, 3, 3, 3, 2, -# 2, 1, 3, 2, 3, 3, 3, 2, 2, 3, 2, 3, 3, 3, 3, -# 4, 5, 4, 3, 4, 3, 2, 3, 4, 4, 5, 3, 2, 4, 3, -# 2, 1, 3, 2, 4, 5, 4, 1, 3, 2, 6, 3, 3, 3, 3, -# 5, 5, 5, 5, 5, 2, 5, 2, 4, 4, 1, 6, 5, 5, 5, -# 5, 1, 2, 4, 3, 5, 3, 2, 4, 3, 3, 4, 4, 4, 4, -# 2, 1, 5, 3, 4, 4, 5, 3, 4, 1, 6, 4, 2, 3, 3, -# 4, 5, 4, 6, 5, 3, 5, 3, 5, 2, 5, 2, 2, 2, 3, -# 1, 1, 4, 2, 4, 5, 2, 5, 5, 3, 6, 1, 1, 2, 1) -# ) -# boeker <- makeRepgrid(args) -# boeker <- setScale(boeker, 1, 6) -# save("boeker", file="../data/boeker.RData") - - -#////////////////////////////////////////////////////////////////////////////// - -#' Grid data from Fransella, Bell and Bannister (2003). -#' -#' A dataset used throughout the book "A Manual for Repertory Grid Technique" -#' (Fransella, Bell and Bannister, 2003, p. 60). -#' -#' @name data-fbb2003 -#' @aliases fbb2003 -#' @docType data -#' @references Fransella, F., Bell, R. & Bannister, D. (2003). A Manual for Repertory -#' Grid Technique (2. Ed.). Chichester: John Wiley & Sons. -#' @keywords data -#' -NULL - - -# args <- list( -# name= c("self", "my father", "an old flame", "an ethical person", "my mother", -# "a rejected teacher", "as I would love to be", "a pitied person"), -# l.name=c("clever", "disorganized", "listens", "no clear view", "understands me", -# "ambitious", "respected", "distant", "rather aggressive"), -# r.name=c("not bright", "organized", "doesn't hear", "clear view of life", "no understanding", -# "no ambition", "not respected", "warm", "not aggressive"), -# scores =c(2,1,6,3,5,7,1,5, -# 6,6,4,5,2,2,5,2, -# 3,1,6,3,3,7,1,4, -# 5,6,3,3,3,5,7,3, -# 3,2,6,2,2,6,2,5, -# 6,3,5,4,7,3,3,5, -# 2,2,4,2,5,6,1,4, -# 3,3,7,3,5,1,6,5, -# 1,3,3,3,5,2,5,7) -# ) -# -# fbb2003 <- makeRepgrid(args) -# fbb2003 <- setScale(fbb2003, 1, 7) -# save("fbb2003", file="../data/fbb2003.RData") - - -#////////////////////////////////////////////////////////////////////////////// - -#' Grid data from Feixas and Saul (2004). -#' -#'A description by the authors: -#' "When Teresa, 22 years old, was seen by the second author (LAS) at the -#' psychological services of the University of Salamanca, she was in the -#' final year of her studies in chemical sciences. Although Teresa proves -#' to be an excellent student, she reveals serious doubts about her self worth. -#' She cries frequently, and has great difficulty in meeting others, -#' even though she has a boyfriend who is extremely supportive. Teresa -#' is anxiously hesitant about accepting a new job which would involve moving -#' to another city 600 Km away from home." (Feixas & Saul, 2004, p. 77). -#' -#' @name data-feixas2004 -#' @aliases feixas2004 -#' @docType data -#' @references Feixas, G., & Saul, L. A. (2004). The Multi-Center Dilemma Project: -#' an investigation on the role of cognitive conflicts in health. -#' *The Spanish Journal of Psychology, 7*(1), 69-78. -#' -#' @keywords data -#' -NULL - -# args <- list( -# name= c("Self now", "Mother", "Father", "Brother", "Boyfriend", "Friend 1", -# "Friend 2", "Non-grata", "Friend 3", "Cousin", "Godmother", "Friend 4", -# "Ideal Self"), -# l.name= c("Pessimistic", "Self-demanding", "Fearful", "Lives to work", -# "Imposes his/her wishes", "Teasing", "Appreciates others", "Aggressive", -# "Concerned about others", "Avaricious", "Sensitive", "Cheeky", "Hypocritical", -# "Blackmailer", "Appears stronger than is", "Does not look after the friendship", -# "Non Accessible", "Introverted", "Gets depressed easily", -# "Tries to find the good in things"), -# r.name= c("Optimistic", "Takes it easy", "Enterprising", "Works to live", -# "Tolerant with others", "Touchy", "Does not appreciate others", -# "Calm", "Selfish", "Generous", "Materialistic, superficial", "Respectful", -# "Sincere", "Non blackmailer", "Natural", "Looks after the friendship", -# "Accessible", "Extroverted", "Does not get depressed easily", -# "Sees only the negative"), -# scores= c(1, 1, 5, 2, 7, 3, 6, 2, 6, 4, 3, 2, 7, -# 1, 6, 6, 2, 2, 5, 6, 3, 5, 6, 4, 5, 4, -# 2, 2, 6, 2, 4, 5, 6, 5, 2, 3, 4, 5, 5, -# 5, 1, 2, 2, 6, 6, 6, 1, 6, 7, 6, 6, 7, -# 6, 2, 1, 1, 4, 3, 6, 1, 7, 3, 4, 2, 7, -# 2, 7, 1, 6, 4, 3, 4, 6, 3, 3, 5, 6, 3, -# 2, 6, 6, 6, 1, 5, 4, 7, 4, 2, 2, 5, 1, -# 6, 4, 2, 2, 7, 4, 6, 2, 6, 6, 6, 3, 7, -# 2, 2, 6, 7, 2, 3, 5, 7, 3, 3, 2, 2, 2, -# 6, 1, 1, 1, 7, 5, 5, 1, 6, 3, 3, 6, 7, -# 1, 5, 7, 7, 1, 4, 5, 7, 1, 4, 3, 4, 1, -# 6, 6, 5, 4, 6, 6, 6, 1, 6, 5, 6, 5, 7, -# 5, 4, 4, 2, 6, 5, 5, 1, 6, 6, 5, 4, 7, -# 3, 2, 2, 1, 5, 6, 6, 1, 6, 6, 6, 3, 7, -# 6, 3, 1, 2, 5, 2, 4, 2, 7, 6, 6, 5, 6, -# 6, 3, 3, 3, 6, 2, 1, 2, 4, 4, 6, 4, 7, -# 5, 2, 2, 1, 4, 2, 4, 1, 6, 3, 5, 2, 7, -# 1, 2, 6, 2, 4, 5, 7, 5, 2, 6, 6, 5, 5, -# 1, 2, 6, 3, 6, 3, 7, 6, 1, 3, 3, 3, 6, -# 6, 6, 4, 6, 1, 5, 2, 7, 6, 3, 3, 5, 1) -# ) -# -# feixas2004 <- makeRepgrid(args) -# feixas2004 <- setScale(feixas2004, 1, 7) -# save("feixas2004", file="../data/feixas2004.RData") - - - - - - - - - -#////////////////////////////////////////////////////////////////////////////// - -#' Case as described by the authors: -#' "Sarah, aged 32, was referred with problems of depression and sexual -#' difficulties relating to childhood sexual abuse. She had three -#' children and was living with her male partner. -#' From the age of 9, her brother, an adult, had sexually abused Sarah. -#' She attended a group for survivors of child sexual abuse and -#' completed repertory grids prior to the group, immediately after the -#' group and at 3- and 6-month follow-up." (Leach et al. 2001, p. 230).\cr \cr -#' -#' `leach2001a` is the pre-therapy, `leach2001b` -#' is the post-therapy therapy dataset. The construct and elements are -#' identical. -#' -#' @title Pre- and post therapy dataset from Leach et al. (2001). -#' -#' @name data-leach2001 -#' @aliases leach2001a leach2001b -#' @docType data -#' -#' @references Leach, C., Freshwater, K., Aldridge, J., & -#' Sunderland, J. (2001). Analysis of repertory grids -#' in clinical practice. *The British Journal -#' of Clinical Psychology, 40*, 225-248. -#' -#' @keywords data -#' -NULL - -# name.abb <- c("CS", "SN", "WG", "MG", "Fa", "Pa", "IS", "Mo", "AC") # not included yet -# args <- list( -# name= c("Child self", "Self now", "Women in general", -# "Men in general", "Father", "Partner", "Ideal self", -# "Mother", "Abuser in childhood"), -# l.name= c("assertive", "confident", "does not feel guilty", "abusive", -# "frightening", "untrustworthy", "powerful", "big headed", -# "independent", "confusing", "guilty", "cold", "masculine", -# "interested in sex"), -# r.name= c("not assertive", "unconfident", "feels guilty", "not abusive", -# "not frightening", "trustworthy", "powerless", "not big headed", -# "dependent", "not confusing", "not guilty", "shows feelings", -# "feminine", "not interested in sex"), -# scores= c(2,7,4,2,3,5,3,1,1, -# 1,7,3,2,2,4,2,1,1, -# 1,6,4,2,1,1,1,1,1, -# 7,7,4,6,7,6,7,3,1, -# 7,7,4,5,7,7,7,3,2, -# 7,7,6,5,7,7,7,3,1, -# 7,5,4,2,3,5,2,1,1, -# 7,5,4,2,6,6,4,2,1, -# 5,6,3,2,2,4,1,3,1, -# 7,2,4,4,7,6,7,1,2, -# 7,3,4,4,7,6,7,4,1, -# 7,3,5,4,7,7,6,2,6, -# 7,7,5,1,1,2,5,2,1, -# 7,5,3,1,1,1,2,7,1 )) -# leach2001a <- makeRepgrid(args) -# leach2001a <- setScale(leach2001a, 1, 7) -# save("leach2001a", file="../data/leach2001a.RData") - - -#////////////////////////////////////////////////////////////////////////////// - - -# name.abb <- c("CS", "SN", "WG", "MG", "Fa", "Pa", "IS", "Mo", "AC") # not included yet -# args <- list( -# name= c("Child self", "Self now", "Women in general", -# "Men in general", "Father", "Partner", "Ideal self", -# "Mother", "Abuser in childhood"), -# l.name= c("assertive", "confident", "does not feel guilty", "abusive", -# "untrustworthy", "guilty", "big headed", "frightening", -# "cold", "powerful", "confusing", "not interested in sex", -# "dependent", "masculine"), -# r.name= c("not assertive", "unconfident", "feels guilty", "not abusive", -# "trustworthy", "not guilty", "not big headed", -# "not frightening", "shows feelings", "powerless", -# "not confusing", "interested in sex", "independent", -# "feminine"), -# scores= c( 4,5,5,3,6,6,2,1,1, -# 3,6,4,3,3,5,1,1,1, -# 2,4,4,2,1,2,1,1,1, -# 7,5,4,4,7,7,7,3,1, -# 7,7,6,5,7,7,7,3,1, -# 7,7,4,4,7,7,7,5,1, -# 6,6,4,4,7,5,7,4,1, -# 7,6,4,4,7,7,7,2,4, -# 5,6,6,4,7,7,7,2,5, -# 6,3,3,2,3,5,1,1,1, -# 7,3,6,6,6,6,7,1,3, -# 1,4,4,4,5,6,6,1,7, -# 3,2,6,5,5,4,6,3,6, -# 6,6,7,1,2,1,7,4,1 )) -# leach2001b <- makeRepgrid(args) -# leach2001b <- setScale(leach2001b, 1, 7) -# save("leach2001b", file="../data/leach2001b.RData") - - - -#////////////////////////////////////////////////////////////////////////////// - -#' Grid data from Mackay (1992). Data set 'Grid C'- -#' -#' -#' used in Mackay's paper on inter-element correlation -#' (1992, p. 65). -#' -#' @name data-mackay1992 -#' @aliases mackay1992 -#' @docType data -#' @references Mackay, N. (1992). Identification, reflection, -#' and correlation: Problems in the bases of repertory -#' grid measures. *International Journal of Personal -#' Construct Psychology, 5*(1), 57-75. -#' -#' @keywords data -#' -NULL - - -# args <- list( -# name= c("Self", "Ideal self", "Mother", "Father", "Spouse", -# "Disliked person"), -# l.name=c("Quick", "*Satisfied", "Talkative", "*Succesful", -# "Emotional", "*Caring"), -# r.name=c("*Slow", "Bitter", "*Quiet", "Loser", "*Calm", -# "Selfish"), -# scores =c(7,4,7,5,3,3, -# 7,7,3,5,2,3, -# 6,4,6,5,5,2, -# 6,7,2,2,3,2, -# 5,6,5,4,4,1, -# 4,7,6,4,5,1) -# ) -# -# mackay1992 <- makeRepgrid(args) -# mackay1992 <- setScale(mackay1992, 1, 7) -# save("mackay1992", file="../data/mackay1992.RData") - - -#////////////////////////////////////////////////////////////////////////////// - -#' Grid data from Raeithel (1998). -#' -#' Grid data to demonstrate the use of Bertin diagrams (Raeithel, 1998, p. 223). -#' The context of its administration is unknown. -#' -#' @name data-raeithel -#' @aliases raeithel -#' @docType data -#' @references Raeithel, A. (1998). Kooperative Modellproduktion von Professionellen -#' und Klienten. Erlaeutert am Beispiel des Repertory Grid. -#' In A. Raeithel (1998). Selbstorganisation, Kooperation, -#' Zeichenprozess. Arbeiten zu einer kulturwissenschaftlichen, -#' anwendungsbezogenen Psychologie (p. 209-254). Opladen: -#' Westdeutscher Verlag. -#' -#' @keywords data -NULL - -# args <- list( -# name=c("Freund", "Therapeut", "Ideal", "Arzt", "Ich vorher", "Virus", -# "Mutter", "Schwester", "Partner", "Vater", "Neg. Person", "Ich", -# "Freundin"), -# l.name=c("charakterlos", "uninteressiert", "sich gehen lassen", -# "unerfahren", "abschaetzbar", "mutig", "leichtfuessig", -# "kuehl", "egoistisch eigennuetzig", "angepasst", "offen", -# "unvorsichtig", "bruederlich freundschaftlich"), -# r.name=c("Charakter haben", "interessiert", "zielstrebig", "erfahren", -# "unberechenbar", "feige", "schwerfaellig", "warmherzig", -# "lebensbejahend sozial", "unangepasst", "hinterhaeltig", -# "diszipliniert gesund", "vaeterlich autoritaer"), -# scores= c( 1, 1, 1, 1, 1, -1, -1, -1, 1, -1, -1, 1, 1, -# 1, 1, 1, 1, 1, 1, -1, -1, 1, 1, -1, 1, 1, -# 1, 1, 1, 1, 1, 1, -1, -1, 1, -1, -1, 1, 1, -# 1, 1, 1, 1, 1, 1, -1, -1, -1, 0, -1, 1, 1, -# -1, 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, 1, 0, -# -1, -1, -1, -1, 1, 1, 1, 1, -1, 1, 1, 1, -1, -# -1, -1, -1, -1, -1, -1, 1, 1, -1, 1, 0, 1, -1, -# 1, 1, 1, 0, -1, -1, -1, 1, 1, 1, 1, 0, -1, -# 1, 1, 1, 1, -1, -1, -1, 0, 1, 1, -1, -1, 0, -# 1, -1, 1, 0, 1, 1, -1, -1, -1, -1, -1, -1, -1, -# -1, -1, -1, -1, 1, 1, 1, -1, -1, -1, 1, -1, -1, -# -1, -1, 1, 1, -1, 1, 0, 1, -1, 1, -1, 1, -1, -# 0, -1, -1, 1, -1, 0, 0, -1, 0, 1, 0, 0, -1) -# ) -# -# raeithel <- makeRepgrid(args) -# raeithel <- setScale(raeithel, -1, 1) -# save("raeithel", file="../data/raeithel.RData") - - -#////////////////////////////////////////////////////////////////////////////// - -#' Drug addict's grid data set from Slater (1977, p. 32). -#' -#' @name data-slater1977a -#' @aliases slater1977a -#' @docType data -#' @references Slater, P. (1977). *The measurement of intrapersonal space -#' by grid technique*. London: Wiley. -#' -#' @keywords data -#' -NULL - -# args <- list( -# name=c("Alcohol", "Barbiturates", "Cannabis", "Cocain", "Drynomil", -# "Heroin", "L.S.D.", "Madryx", "Methedrine (injections)"), -# r.name=c( "Makes me talk more", -# "Makes me feel high", -# "Makes me feel blocked", -# "Makes me feel sleepy", -# "Gives me a warminn feeling inside", -# "Makes me feel drunk", -# "Makes me imagine things", -# "Makes me feel sick", -# "Makes me do things without knowing what I'm doing", -# "Hepls me enjoy things", -# "Gives me a good buzz", -# "Makes me tense", -# "Makes me feel sexy", -# "After taking it I may see or hear people whoe aren't really there"), -# l.name=rep("", 14), -# scores=c( 2,2,4,1,1,4,5,2,1, -# 3,1,2,1,1,2,1,1,2, -# 3,1,2,1,1,2,1,1,2, -# 3,1,2,5,5,2,5,1,5, -# 2,1,2,1,4,2,3,1,3, -# 2,1,2,5,5,2,5,1,4, -# 3,3,1,3,2,2,1,3,2, -# 3,3,2,3,3,3,3,3,3, -# 3,1,4,3,2,3,4,2,2, -# 3,2,2,2,1,2,1,2,4, -# 3,1,1,1,3,1,1,1,3, -# 3,5,2,1,1,5,3,5,1, -# 2,5,2,4,3,5,3,5,4, -# 3,3,3,2,1,3,2,3,2) -# ) -# -# slater1977a <- makeRepgrid(args) -# slater1977a <- setScale(slater1977a, 1, 5) -# save("slater1977a", file="../data/slater1977a.RData") - - -#////////////////////////////////////////////////////////////////////////////// - -#' Grid data from Slater (1977). -#' -#' Grid data (ranked) from a seventeen year old female psychiatric patient -#' (Slater, 1977, p. 110). She was depressed, anxious and took to cutting -#' herself. The data was originally reported by Watson (1970). -#' -#' @name data-slater1977b -#' @aliases slater1977b -#' @docType data -#' @references Slater, P. (1977). *The measurement of intrapersonal space -#' by grid technique*. London: Wiley. -#' -#' Watson, J. P. (1970). The relationship between a self-mutilating -#' patient and her doctor. *Psychotherapy and Psychosomatics, -#' 18*(1), 67-73. -#' -#' @keywords data -#' -NULL - -# args <- list( -# name= c("Wanting to talk to someone and being unable to", -# "Having the same thoughts for a long time", -# "Being in a crowd", "Seeing G.", "Being at home", -# "Being in hospital", "Being with my mother", -# "Being with Dr. W.", "Being with Mrs. M.", "Being with my father"), -# r.name= c("Make me cut myself", "Make me think people are unfriendly", -# "Make me feel depressed", "Make me feel angry", -# "Make me feel scared", "Make me feel more grown-up", -# "Make me feel more like a child", "Make me feel lonely", -# "Help me in the long run", "Make me feel cheerful"), -# l.name= rep("", 10), -# scores= matrix(c(2,1,3,6,4,5,7,8,10,9, -# 1,3,6,2,4,7,5,8,10,9, -# 2,5,3,1,4,6,7,10,9,8, -# 1,2,4,3,7,6,10,5,8,9, -# 2,3,5,1,9,7,10,4,6,8, -# 5,4,7,1,2,6,3,9,10,8, -# 2,7,5,9,1,8,3,6,10,4, -# 9,8,7,1,5,6,4,2,10,3, -# 5,9,10,1,8,2,6,3,4,7, -# 9,8,10,1,5,6,3,4,7,2))) -# slater1977b <- makeRepgrid(args) -# slater1977b <- setScale(slater1977b, 1, 10) -# save("slater1977b", file="../data/slater1977b.RData") - - -#////////////////////////////////////////////////////////////////////////////// - - - - - - - - - - - +# ////////////////////////////////////////////////////////////////////////////// +# +# data that comes along with the OpenRepGrid package +# +# ////////////////////////////////////////////////////////////////////////////// + + +# ////////////////////////////////////////////////////////////////////////////// + +#' Grid data from Bell (2010). +#' +#' Grid data originated (but is not shown in the paper) from a study by Haritos, +#' Gindinis, Doan and Bell (2004) on element role titles. It was used to +#' demonstrate the effects of construct alignment in Bell (2010, p. 46). +#' +#' @name data-bell2010 +#' @aliases bell2010 +#' @docType data +#' @references Bell, R. C. (2010). A note on aligning constructs. +#' *Personal Construct Theory and Practice*, 7, 43-48. +#' +#' Haritos, A., Gindidis, A., Doan, C., & Bell, R. C. (2004). +#' The effect of element role titles on construct structure +#' and content. *Journal of constructivist +#' psychology, 17*(3), 221-236. +#' +#' @keywords data +#' +NULL + +# args <- list( +# name=c( "self", "closest friend of the same sex", "the unhappiest person you know", +# "A person of the opposite sex that you don't get along with", +# "A teacher you respected", +# "Mother (or the person who filled that kind of role)", +# "A person of the opposite sex that you like more than you dislike", +# "The most confident person you know", +# "A person you work well with (at job or on sports team etc)", +# "A teacher you did not respect"), +# l.name=c( "relaxed", "not so smart (academically)", "dislikes sports", +# "not interactive", "not transparent", "insensitive", "fearful&timid", +# "rough", "accept as it is"), +# r.name=c( "worried & tense", "smart (academically)", "loves sports", +# "loves people", "transparent", "sensitive", "fearless", "gentle", +# "loves to argue"), +# scores= c(4,4,6,5,3,6,5,2,2,6, +# 6,7,6,5,7,4,6,7,4,7, +# 6,3,7,6,4,4,2,3,6,3, +# 6,7,5,6,6,5,6,7,7,4, +# 6,4,5,7,3,7,6,5,6,3, +# 4,6,5,4,4,6,5,3,4,2, +# 5,4,4,6,5,3,5,6,5,5, +# 5,6,6,4,5,7,7,3,5,6, +# 5,5,6,7,4,4,6,7,5,5) +# ) +# bell2010 <- makeRepgrid(args) +# bell2010 <- setScale(bell2010, 1, 7) +# save("bell2010", file="../data/bell2010.RData") + + +# ////////////////////////////////////////////////////////////////////////////// + +#' Grid data from Bell and McGorry (1992). +#' +#' The grid data set is used in Bell's technical report "Using SPSS to Analyse +#' Repertory Grid Data" (1997, p. 6). Originally, the data comes from a study +#' by Bell and McGorry (1992). +#' +#' @name data-bellmcgorry1992 +#' @aliases bellmcgorry1992 +#' @docType data +#' @references Bell, R. C. (1977). *Using SPSS to +#' Analyse Repertory Grid Data*. Technical Report, +#' University of Melbourne. +#' +#' Bell, R. C., & McGorry, P. (1992). The analysis of repertory +#' grids used to monitor the perceptions of recovering psychotic +#' patients. In A. Thomson & P. Cummins (Eds.), *European Perspectives +#' in Personal Construct Psychology* (p. 137-150). +#' Lincoln, UK: European Personal Construct Association. +#' +#' @keywords data +#' +NULL + + +# abbreviations not yet included +# c("bipolar", "schiz", "psychiat", "criminal", "average", +# "aids", "diabetes", "cancer", "stress", "usualme", "menow", +# "meth", "staffme", "idealme", "conlab") +# args <- list( +# name= c('person with manic depressive illness', 'person with schizophrenia', +# 'psychiatric patient','convicted criminal','average person', +# 'AIDS patient','person with diabetes','person with cancer', +# 'person under stress','myself as I usually am','myself as I am now', +# 'myself as I will be in six months','myself as the staff see me', +# 'my ideal self'), +# l.name=c("good", "dependable", "safe", "clearheaded", "stable", +# "predictable", "intelligent", "free", "healthy", "honest", +# "rational", "independent", "calm", "understood"), +# r.name=rep("", 14), +# scores =c(3,5,3,7,4,2,1,1,7,1,1,1,2,1, +# 4,5,4,7,3,3,1,2,7,2,1,1,3,1, +# 6,7,4,7,3,7,1,2,6,1,1,1,2,1, +# 7,7,4,7,2,7,2,4,7,1,1,1,2,1, +# 7,7,5,7,2,7,1,4,7,2,2,1,3,1, +# 7,7,5,7,6,5,4,4,7,7,7,3,7,7, +# 4,5,4,7,2,1,2,2,7,1,1,1,2,1, +# 7,7,5,7,1,7,1,1,1,1,7,1,7,1, +# 6,7,4,7,1,7,7,7,7,1,4,1,4,1, +# 5,5,4,7,1,1,3,4,4,1,1,1,3,1, +# 5,7,5,6,1,2,2,4,5,1,1,1,3,1, +# 5,6,5,7,1,5,3,4,5,1,1,1,2,1, +# 6,5,5,7,2,7,3,4,7,1,1,1,1,1, +# 6,7,6,7,1,7,3,4,7,3,7,1,7,1) +# ) +# +# bellmcgorry1992 <- makeRepgrid(args) +# bellmcgorry1992 <- setScale(bellmcgorry1992, 1, 7) +# save("bellmcgorry1992", file="../data/bellmcgorry1992.RData") + + +# ////////////////////////////////////////////////////////////////////////////// + +#' Grid data from Boeker (1996). +#' +#' Grid data from a schizophrenic patient undergoing psychoanalytically +#' oriented psychotherapy. The data was taken during the last stage of +#' therapy (Boeker, 1996, p. 163). +#' +#' @name data-boeker +#' @aliases boeker +#' @docType data +#' @references Boeker, H. (1996). The reconstruction of the self in +#' the psychotherapy of chronic schizophrenia: a case study +#' with the Repertory Grid Technique. In: Scheer, J. W., +#' Catina, A. (Eds.): *Empirical Constructivism in Europe - +#' The Personal Construct Approach* (p. 160-167). +#' Giessen: Psychosozial-Verlag. +#' +#' @keywords data +NULL + +# Heinz Boeker in Scheer & Catina (1996, p.163) +# scale used: 1 to 6 + +# args <- list( +# name=c("self", "ideal self", "mother", "father", "kurt", "karl", +# "george", "martin", "elizabeth", "therapist", "irene", +# "childhood self", "self before illness", "self with delusion" , +# "self as dreamer"), +# l.name=c("balanced", "isolated", "closely integrated", "discursive", +# "open minded", "dreamy", "practically oriented", "playful", +# "socially minded", "quarrelsome", "artistic", "scientific", +# "introvert", "wanderlust"), +# r.name=c("get along with conflicts", "sociable", "excluded", "passive", +# "indifferent", "dispassionate", "depressed", "serious", +# "selfish", "peaceful", "technical", "emotional", +# "extrovert", "home oriented"), +# scores= c(1, 4, 2, 2, 3, 5, 2, 5, 4, 2, 6, 2, 2, 3, 3, +# 3, 6, 3, 5, 5, 4, 5, 4, 5, 4, 4, 4, 2, 2, 3, +# 2, 2, 2, 3, 5, 3, 2, 3, 2, 3, 3, 4, 4, 5, 3, +# 4, 1, 3, 1, 2, 4, 2, 3, 3, 2, 3, 3, 3, 5, 4, +# 2, 1, 2, 1, 2, 4, 4, 2, 4, 2, 6, 3, 2, 2, 3, +# 4, 5, 3, 5, 4, 5, 4, 5, 4, 4, 6, 3, 3, 3, 2, +# 2, 1, 3, 2, 3, 3, 3, 2, 2, 3, 2, 3, 3, 3, 3, +# 4, 5, 4, 3, 4, 3, 2, 3, 4, 4, 5, 3, 2, 4, 3, +# 2, 1, 3, 2, 4, 5, 4, 1, 3, 2, 6, 3, 3, 3, 3, +# 5, 5, 5, 5, 5, 2, 5, 2, 4, 4, 1, 6, 5, 5, 5, +# 5, 1, 2, 4, 3, 5, 3, 2, 4, 3, 3, 4, 4, 4, 4, +# 2, 1, 5, 3, 4, 4, 5, 3, 4, 1, 6, 4, 2, 3, 3, +# 4, 5, 4, 6, 5, 3, 5, 3, 5, 2, 5, 2, 2, 2, 3, +# 1, 1, 4, 2, 4, 5, 2, 5, 5, 3, 6, 1, 1, 2, 1) +# ) +# boeker <- makeRepgrid(args) +# boeker <- setScale(boeker, 1, 6) +# save("boeker", file="../data/boeker.RData") + + +# ////////////////////////////////////////////////////////////////////////////// + +#' Grid data from Fransella, Bell and Bannister (2003). +#' +#' A dataset used throughout the book "A Manual for Repertory Grid Technique" +#' (Fransella, Bell and Bannister, 2003, p. 60). +#' +#' @name data-fbb2003 +#' @aliases fbb2003 +#' @docType data +#' @references Fransella, F., Bell, R. & Bannister, D. (2003). A Manual for Repertory +#' Grid Technique (2. Ed.). Chichester: John Wiley & Sons. +#' @keywords data +#' +NULL + + +# args <- list( +# name= c("self", "my father", "an old flame", "an ethical person", "my mother", +# "a rejected teacher", "as I would love to be", "a pitied person"), +# l.name=c("clever", "disorganized", "listens", "no clear view", "understands me", +# "ambitious", "respected", "distant", "rather aggressive"), +# r.name=c("not bright", "organized", "doesn't hear", "clear view of life", "no understanding", +# "no ambition", "not respected", "warm", "not aggressive"), +# scores =c(2,1,6,3,5,7,1,5, +# 6,6,4,5,2,2,5,2, +# 3,1,6,3,3,7,1,4, +# 5,6,3,3,3,5,7,3, +# 3,2,6,2,2,6,2,5, +# 6,3,5,4,7,3,3,5, +# 2,2,4,2,5,6,1,4, +# 3,3,7,3,5,1,6,5, +# 1,3,3,3,5,2,5,7) +# ) +# +# fbb2003 <- makeRepgrid(args) +# fbb2003 <- setScale(fbb2003, 1, 7) +# save("fbb2003", file="../data/fbb2003.RData") + + +# ////////////////////////////////////////////////////////////////////////////// + +#' Grid data from Feixas and Saul (2004). +#' +#' A description by the authors: +#' "When Teresa, 22 years old, was seen by the second author (LAS) at the +#' psychological services of the University of Salamanca, she was in the +#' final year of her studies in chemical sciences. Although Teresa proves +#' to be an excellent student, she reveals serious doubts about her self worth. +#' She cries frequently, and has great difficulty in meeting others, +#' even though she has a boyfriend who is extremely supportive. Teresa +#' is anxiously hesitant about accepting a new job which would involve moving +#' to another city 600 Km away from home." (Feixas & Saul, 2004, p. 77). +#' +#' @name data-feixas2004 +#' @aliases feixas2004 +#' @docType data +#' @references Feixas, G., & Saul, L. A. (2004). The Multi-Center Dilemma Project: +#' an investigation on the role of cognitive conflicts in health. +#' *The Spanish Journal of Psychology, 7*(1), 69-78. +#' +#' @keywords data +#' +NULL + +# args <- list( +# name= c("Self now", "Mother", "Father", "Brother", "Boyfriend", "Friend 1", +# "Friend 2", "Non-grata", "Friend 3", "Cousin", "Godmother", "Friend 4", +# "Ideal Self"), +# l.name= c("Pessimistic", "Self-demanding", "Fearful", "Lives to work", +# "Imposes his/her wishes", "Teasing", "Appreciates others", "Aggressive", +# "Concerned about others", "Avaricious", "Sensitive", "Cheeky", "Hypocritical", +# "Blackmailer", "Appears stronger than is", "Does not look after the friendship", +# "Non Accessible", "Introverted", "Gets depressed easily", +# "Tries to find the good in things"), +# r.name= c("Optimistic", "Takes it easy", "Enterprising", "Works to live", +# "Tolerant with others", "Touchy", "Does not appreciate others", +# "Calm", "Selfish", "Generous", "Materialistic, superficial", "Respectful", +# "Sincere", "Non blackmailer", "Natural", "Looks after the friendship", +# "Accessible", "Extroverted", "Does not get depressed easily", +# "Sees only the negative"), +# scores= c(1, 1, 5, 2, 7, 3, 6, 2, 6, 4, 3, 2, 7, +# 1, 6, 6, 2, 2, 5, 6, 3, 5, 6, 4, 5, 4, +# 2, 2, 6, 2, 4, 5, 6, 5, 2, 3, 4, 5, 5, +# 5, 1, 2, 2, 6, 6, 6, 1, 6, 7, 6, 6, 7, +# 6, 2, 1, 1, 4, 3, 6, 1, 7, 3, 4, 2, 7, +# 2, 7, 1, 6, 4, 3, 4, 6, 3, 3, 5, 6, 3, +# 2, 6, 6, 6, 1, 5, 4, 7, 4, 2, 2, 5, 1, +# 6, 4, 2, 2, 7, 4, 6, 2, 6, 6, 6, 3, 7, +# 2, 2, 6, 7, 2, 3, 5, 7, 3, 3, 2, 2, 2, +# 6, 1, 1, 1, 7, 5, 5, 1, 6, 3, 3, 6, 7, +# 1, 5, 7, 7, 1, 4, 5, 7, 1, 4, 3, 4, 1, +# 6, 6, 5, 4, 6, 6, 6, 1, 6, 5, 6, 5, 7, +# 5, 4, 4, 2, 6, 5, 5, 1, 6, 6, 5, 4, 7, +# 3, 2, 2, 1, 5, 6, 6, 1, 6, 6, 6, 3, 7, +# 6, 3, 1, 2, 5, 2, 4, 2, 7, 6, 6, 5, 6, +# 6, 3, 3, 3, 6, 2, 1, 2, 4, 4, 6, 4, 7, +# 5, 2, 2, 1, 4, 2, 4, 1, 6, 3, 5, 2, 7, +# 1, 2, 6, 2, 4, 5, 7, 5, 2, 6, 6, 5, 5, +# 1, 2, 6, 3, 6, 3, 7, 6, 1, 3, 3, 3, 6, +# 6, 6, 4, 6, 1, 5, 2, 7, 6, 3, 3, 5, 1) +# ) +# +# feixas2004 <- makeRepgrid(args) +# feixas2004 <- setScale(feixas2004, 1, 7) +# save("feixas2004", file="../data/feixas2004.RData") + + + + + + + + + +# ////////////////////////////////////////////////////////////////////////////// + +#' Case as described by the authors: +#' "Sarah, aged 32, was referred with problems of depression and sexual +#' difficulties relating to childhood sexual abuse. She had three +#' children and was living with her male partner. +#' From the age of 9, her brother, an adult, had sexually abused Sarah. +#' She attended a group for survivors of child sexual abuse and +#' completed repertory grids prior to the group, immediately after the +#' group and at 3- and 6-month follow-up." (Leach et al. 2001, p. 230).\cr \cr +#' +#' `leach2001a` is the pre-therapy, `leach2001b` +#' is the post-therapy therapy dataset. The construct and elements are +#' identical. +#' +#' @title Pre- and post therapy dataset from Leach et al. (2001). +#' +#' @name data-leach2001 +#' @aliases leach2001a leach2001b +#' @docType data +#' +#' @references Leach, C., Freshwater, K., Aldridge, J., & +#' Sunderland, J. (2001). Analysis of repertory grids +#' in clinical practice. *The British Journal +#' of Clinical Psychology, 40*, 225-248. +#' +#' @keywords data +#' +NULL + +# name.abb <- c("CS", "SN", "WG", "MG", "Fa", "Pa", "IS", "Mo", "AC") # not included yet +# args <- list( +# name= c("Child self", "Self now", "Women in general", +# "Men in general", "Father", "Partner", "Ideal self", +# "Mother", "Abuser in childhood"), +# l.name= c("assertive", "confident", "does not feel guilty", "abusive", +# "frightening", "untrustworthy", "powerful", "big headed", +# "independent", "confusing", "guilty", "cold", "masculine", +# "interested in sex"), +# r.name= c("not assertive", "unconfident", "feels guilty", "not abusive", +# "not frightening", "trustworthy", "powerless", "not big headed", +# "dependent", "not confusing", "not guilty", "shows feelings", +# "feminine", "not interested in sex"), +# scores= c(2,7,4,2,3,5,3,1,1, +# 1,7,3,2,2,4,2,1,1, +# 1,6,4,2,1,1,1,1,1, +# 7,7,4,6,7,6,7,3,1, +# 7,7,4,5,7,7,7,3,2, +# 7,7,6,5,7,7,7,3,1, +# 7,5,4,2,3,5,2,1,1, +# 7,5,4,2,6,6,4,2,1, +# 5,6,3,2,2,4,1,3,1, +# 7,2,4,4,7,6,7,1,2, +# 7,3,4,4,7,6,7,4,1, +# 7,3,5,4,7,7,6,2,6, +# 7,7,5,1,1,2,5,2,1, +# 7,5,3,1,1,1,2,7,1 )) +# leach2001a <- makeRepgrid(args) +# leach2001a <- setScale(leach2001a, 1, 7) +# save("leach2001a", file="../data/leach2001a.RData") + + +# ////////////////////////////////////////////////////////////////////////////// + + +# name.abb <- c("CS", "SN", "WG", "MG", "Fa", "Pa", "IS", "Mo", "AC") # not included yet +# args <- list( +# name= c("Child self", "Self now", "Women in general", +# "Men in general", "Father", "Partner", "Ideal self", +# "Mother", "Abuser in childhood"), +# l.name= c("assertive", "confident", "does not feel guilty", "abusive", +# "untrustworthy", "guilty", "big headed", "frightening", +# "cold", "powerful", "confusing", "not interested in sex", +# "dependent", "masculine"), +# r.name= c("not assertive", "unconfident", "feels guilty", "not abusive", +# "trustworthy", "not guilty", "not big headed", +# "not frightening", "shows feelings", "powerless", +# "not confusing", "interested in sex", "independent", +# "feminine"), +# scores= c( 4,5,5,3,6,6,2,1,1, +# 3,6,4,3,3,5,1,1,1, +# 2,4,4,2,1,2,1,1,1, +# 7,5,4,4,7,7,7,3,1, +# 7,7,6,5,7,7,7,3,1, +# 7,7,4,4,7,7,7,5,1, +# 6,6,4,4,7,5,7,4,1, +# 7,6,4,4,7,7,7,2,4, +# 5,6,6,4,7,7,7,2,5, +# 6,3,3,2,3,5,1,1,1, +# 7,3,6,6,6,6,7,1,3, +# 1,4,4,4,5,6,6,1,7, +# 3,2,6,5,5,4,6,3,6, +# 6,6,7,1,2,1,7,4,1 )) +# leach2001b <- makeRepgrid(args) +# leach2001b <- setScale(leach2001b, 1, 7) +# save("leach2001b", file="../data/leach2001b.RData") + + + +# ////////////////////////////////////////////////////////////////////////////// + +#' Grid data from Mackay (1992). Data set 'Grid C'- +#' +#' +#' used in Mackay's paper on inter-element correlation +#' (1992, p. 65). +#' +#' @name data-mackay1992 +#' @aliases mackay1992 +#' @docType data +#' @references Mackay, N. (1992). Identification, reflection, +#' and correlation: Problems in the bases of repertory +#' grid measures. *International Journal of Personal +#' Construct Psychology, 5*(1), 57-75. +#' +#' @keywords data +#' +NULL + + +# args <- list( +# name= c("Self", "Ideal self", "Mother", "Father", "Spouse", +# "Disliked person"), +# l.name=c("Quick", "*Satisfied", "Talkative", "*Succesful", +# "Emotional", "*Caring"), +# r.name=c("*Slow", "Bitter", "*Quiet", "Loser", "*Calm", +# "Selfish"), +# scores =c(7,4,7,5,3,3, +# 7,7,3,5,2,3, +# 6,4,6,5,5,2, +# 6,7,2,2,3,2, +# 5,6,5,4,4,1, +# 4,7,6,4,5,1) +# ) +# +# mackay1992 <- makeRepgrid(args) +# mackay1992 <- setScale(mackay1992, 1, 7) +# save("mackay1992", file="../data/mackay1992.RData") + + +# ////////////////////////////////////////////////////////////////////////////// + +#' Grid data from Raeithel (1998). +#' +#' Grid data to demonstrate the use of Bertin diagrams (Raeithel, 1998, p. 223). +#' The context of its administration is unknown. +#' +#' @name data-raeithel +#' @aliases raeithel +#' @docType data +#' @references Raeithel, A. (1998). Kooperative Modellproduktion von Professionellen +#' und Klienten. Erlaeutert am Beispiel des Repertory Grid. +#' In A. Raeithel (1998). Selbstorganisation, Kooperation, +#' Zeichenprozess. Arbeiten zu einer kulturwissenschaftlichen, +#' anwendungsbezogenen Psychologie (p. 209-254). Opladen: +#' Westdeutscher Verlag. +#' +#' @keywords data +NULL + +# args <- list( +# name=c("Freund", "Therapeut", "Ideal", "Arzt", "Ich vorher", "Virus", +# "Mutter", "Schwester", "Partner", "Vater", "Neg. Person", "Ich", +# "Freundin"), +# l.name=c("charakterlos", "uninteressiert", "sich gehen lassen", +# "unerfahren", "abschaetzbar", "mutig", "leichtfuessig", +# "kuehl", "egoistisch eigennuetzig", "angepasst", "offen", +# "unvorsichtig", "bruederlich freundschaftlich"), +# r.name=c("Charakter haben", "interessiert", "zielstrebig", "erfahren", +# "unberechenbar", "feige", "schwerfaellig", "warmherzig", +# "lebensbejahend sozial", "unangepasst", "hinterhaeltig", +# "diszipliniert gesund", "vaeterlich autoritaer"), +# scores= c( 1, 1, 1, 1, 1, -1, -1, -1, 1, -1, -1, 1, 1, +# 1, 1, 1, 1, 1, 1, -1, -1, 1, 1, -1, 1, 1, +# 1, 1, 1, 1, 1, 1, -1, -1, 1, -1, -1, 1, 1, +# 1, 1, 1, 1, 1, 1, -1, -1, -1, 0, -1, 1, 1, +# -1, 1, 1, 1, 1, 1, 1, -1, -1, -1, -1, 1, 0, +# -1, -1, -1, -1, 1, 1, 1, 1, -1, 1, 1, 1, -1, +# -1, -1, -1, -1, -1, -1, 1, 1, -1, 1, 0, 1, -1, +# 1, 1, 1, 0, -1, -1, -1, 1, 1, 1, 1, 0, -1, +# 1, 1, 1, 1, -1, -1, -1, 0, 1, 1, -1, -1, 0, +# 1, -1, 1, 0, 1, 1, -1, -1, -1, -1, -1, -1, -1, +# -1, -1, -1, -1, 1, 1, 1, -1, -1, -1, 1, -1, -1, +# -1, -1, 1, 1, -1, 1, 0, 1, -1, 1, -1, 1, -1, +# 0, -1, -1, 1, -1, 0, 0, -1, 0, 1, 0, 0, -1) +# ) +# +# raeithel <- makeRepgrid(args) +# raeithel <- setScale(raeithel, -1, 1) +# save("raeithel", file="../data/raeithel.RData") + + +# ////////////////////////////////////////////////////////////////////////////// + +#' Drug addict's grid data set from Slater (1977, p. 32). +#' +#' @name data-slater1977a +#' @aliases slater1977a +#' @docType data +#' @references Slater, P. (1977). *The measurement of intrapersonal space +#' by grid technique*. London: Wiley. +#' +#' @keywords data +#' +NULL + +# args <- list( +# name=c("Alcohol", "Barbiturates", "Cannabis", "Cocain", "Drynomil", +# "Heroin", "L.S.D.", "Madryx", "Methedrine (injections)"), +# r.name=c( "Makes me talk more", +# "Makes me feel high", +# "Makes me feel blocked", +# "Makes me feel sleepy", +# "Gives me a warminn feeling inside", +# "Makes me feel drunk", +# "Makes me imagine things", +# "Makes me feel sick", +# "Makes me do things without knowing what I'm doing", +# "Hepls me enjoy things", +# "Gives me a good buzz", +# "Makes me tense", +# "Makes me feel sexy", +# "After taking it I may see or hear people whoe aren't really there"), +# l.name=rep("", 14), +# scores=c( 2,2,4,1,1,4,5,2,1, +# 3,1,2,1,1,2,1,1,2, +# 3,1,2,1,1,2,1,1,2, +# 3,1,2,5,5,2,5,1,5, +# 2,1,2,1,4,2,3,1,3, +# 2,1,2,5,5,2,5,1,4, +# 3,3,1,3,2,2,1,3,2, +# 3,3,2,3,3,3,3,3,3, +# 3,1,4,3,2,3,4,2,2, +# 3,2,2,2,1,2,1,2,4, +# 3,1,1,1,3,1,1,1,3, +# 3,5,2,1,1,5,3,5,1, +# 2,5,2,4,3,5,3,5,4, +# 3,3,3,2,1,3,2,3,2) +# ) +# +# slater1977a <- makeRepgrid(args) +# slater1977a <- setScale(slater1977a, 1, 5) +# save("slater1977a", file="../data/slater1977a.RData") + + +# ////////////////////////////////////////////////////////////////////////////// + +#' Grid data from Slater (1977). +#' +#' Grid data (ranked) from a seventeen year old female psychiatric patient +#' (Slater, 1977, p. 110). She was depressed, anxious and took to cutting +#' herself. The data was originally reported by Watson (1970). +#' +#' @name data-slater1977b +#' @aliases slater1977b +#' @docType data +#' @references Slater, P. (1977). *The measurement of intrapersonal space +#' by grid technique*. London: Wiley. +#' +#' Watson, J. P. (1970). The relationship between a self-mutilating +#' patient and her doctor. *Psychotherapy and Psychosomatics, +#' 18*(1), 67-73. +#' +#' @keywords data +#' +NULL + +# args <- list( +# name= c("Wanting to talk to someone and being unable to", +# "Having the same thoughts for a long time", +# "Being in a crowd", "Seeing G.", "Being at home", +# "Being in hospital", "Being with my mother", +# "Being with Dr. W.", "Being with Mrs. M.", "Being with my father"), +# r.name= c("Make me cut myself", "Make me think people are unfriendly", +# "Make me feel depressed", "Make me feel angry", +# "Make me feel scared", "Make me feel more grown-up", +# "Make me feel more like a child", "Make me feel lonely", +# "Help me in the long run", "Make me feel cheerful"), +# l.name= rep("", 10), +# scores= matrix(c(2,1,3,6,4,5,7,8,10,9, +# 1,3,6,2,4,7,5,8,10,9, +# 2,5,3,1,4,6,7,10,9,8, +# 1,2,4,3,7,6,10,5,8,9, +# 2,3,5,1,9,7,10,4,6,8, +# 5,4,7,1,2,6,3,9,10,8, +# 2,7,5,9,1,8,3,6,10,4, +# 9,8,7,1,5,6,4,2,10,3, +# 5,9,10,1,8,2,6,3,4,7, +# 9,8,10,1,5,6,3,4,7,2))) +# slater1977b <- makeRepgrid(args) +# slater1977b <- setScale(slater1977b, 1, 10) +# save("slater1977b", file="../data/slater1977b.RData") + + +# ////////////////////////////////////////////////////////////////////////////// diff --git a/R/dev-functions.r b/R/dev-functions.r index 8f99a1db..30efd697 100644 --- a/R/dev-functions.r +++ b/R/dev-functions.r @@ -1,227 +1,236 @@ -######################### Developer's functions ############################## -### Functions that can be used by developers. Often these are ### -### are simple wrappers to access slots of the repgrid object. ### -### They are supposd to facilitate adding new functions for ### -### newcomers to R. ### -### Most functions are documentetd in OpenRepGrid-internal ### -#////////////////////////////////////////////////////////////////////////////// - - -#' Generate a random grid (quasis) of prompted size. -#' -#' This feature is useful for research purposes like -#' exploring distributions of indexes etc. -#' -#' @param nc Number of constructs (default 10). -#' @param ne Number of elements (default 15). -#' @param nwc Number of random words per construct. -#' @param nwe Number of random words per element. -#' @param range Minimal and maximal scale value (default `c(1, 5)`). -#' @param prob The probability of each rating value to occur. -#' If `NULL` (default) the distribution is uniform. -#' @param options Use random sentences as constructs and elements (1) or -#' not (0). If not, the elements and constructs are given -#' default names and are numbered. -#' @return `repgrid` object. -#' -#' @export -#' @examples \dontrun{ -#' -#' x <- randomGrid() -#' x -#' x <- randomGrid(10, 25) -#' x -#' x <- randomGrid(10, 25, options=0) -#' x -#' } -#' -randomGrid <- function(nc=10, ne=15, nwc=8, nwe=5, range=c(1,5), prob=NULL, options=1) -{ - if (options == 1){ # full constructs and element names - elem <- randomSentences(ne, nwe) - left <- randomSentences(nc, nwc) - right <- randomSentences(nc, nwc) - } else { # short element and construct names - elem <- paste("element", seq_len(ne), sep="") - left <- paste("lconstruct", seq_len(nc), sep="") - right <- paste("rconstruct", seq_len(nc), sep="") - } - scores <- sample(range[1]:range[2], nc*ne, - replace=TRUE, prob=prob) - args <- list( name=elem, - l.name=left, - r.name=right, - scores=scores) - x <- makeRepgrid(args) - setScale(x, min=range[1], max=range[2], step=1) -} - - -#' Generate a list of random grids (quasis) of prompted size. -#' -#' This feature is useful for research purposes like -#' exploring distributions of indexes etc. The function is a -#' simple wrapper around [randomGrid()]. -#' -#' @param rep Number of grids to be produced (default is `3`). -#' @param nc Number of constructs (default 10). -#' @param ne Number of elements (default 15). -#' @param nwc Number of random words per construct. -#' @param nwe Number of random words per element. -#' @param range Minimal and maximal scale value (default `c(1, 5)`). -#' @param prob The probability of each rating value to occur. -#' If `NULL` (default) the distribution is uniform. -#' @param options Use random sentences as constructs and elements (1) or -#' not (0). If not, the elements and constructs are given -#' default names and are numbered. -#' @return A list of `repgrid` objects. -#' -#' @export -#' @examples \dontrun{ -#' -#' x <- randomGrids() -#' x -#' x <- randomGrids(5, 3, 3) -#' x -#' x <- randomGrids(5, 3, 3, options=0) -#' x -#' } -#' -randomGrids <- function(rep=3, nc=10, ne=15, nwc=8, nwe=5, - range=c(1,5), prob=NULL, options=1){ - replicate(rep, randomGrid(nc=nc, ne=ne, - nwc=nwc, nwe=nwe, - range=range, prob=prob, - options=options)) -} - - -#' Generate random grids and calculate 'Slater distances' -#' for the elements. -#' -#' All Slater distances are returned as a vector. The values can be used e.g. to assess the -#' distributions standard deviation. -#' -#' @param rep Number of grids to be produced (default is `3`). -#' @param nc Number of constructs (default 10). -#' @param ne Number of elements (default 15). -#' @param range Minimal and maximal scale value (default `c(1, 5)`). -#' @param prob The probability of each rating value to occur. -#' If `NULL` (default) the distribution is uniform. -#' @param progress Whether to show a progress bar. -#' -#' @return A vector containing Slater distance values. -#' @keywords internal -#' @export -#' @seealso [randomGrids()]; -#' [distanceSlater()]; -#' [distanceHartmann()]. -#' -#' @examples \dontrun{ -#' -#' vals <- quasiDistributionDistanceSlater(100, 10, 10, c(1,5), pro=T) -#' vals -#' sd(vals) -#' hist(vals, breaks=50) -#' -#' } -#' -quasiDistributionDistanceSlater <- function(rep, nc, ne, range, prob=NULL, progress=TRUE) -{ - quasis <- randomGrids(rep, nc=nc, ne=ne, range=range, prob=prob, options=0) - if (progress) # whether to show progress bar - lapply_fun <- lapply_pb else - lapply_fun <- lapply - quasis.sd <- lapply_fun(quasis, function(x){ - ds <- distanceSlater(x) - ds[lower.tri(ds, diag=FALSE)] - }) - unlist(quasis.sd) # return as vector -} - - -#' Generate a list with all possible construct reflections of a grid. -#' -#' @param x `repgrid` object. -#' @param progress Whether to show a progress bar (default is `TRUE`). -#' This may be sensible for a larger number of elements. -#' @return A list of `repgrid` objects with all possible permutations -#' of the grid. -#' -#' @export -#' @examples \dontrun{ -#' -#' l <- permuteConstructs(mackay1992) -#' l -#' -#' } -#' -permuteConstructs <- function(x, progress=TRUE){ - reflections <- rep(list(0:1), getNoOfConstructs(x)) - perm <- expand.grid(reflections) # all permutations - if (progress) - apply_used <- apply_pb else - apply_used <- apply - permGridList <- apply_used(perm, 1, function(perm, x){ # make grids with all possible reflections - perm <- as.logical(perm) - ncons <- seq_len(getNoOfConstructs(x)) - swapPoles(x, ncons[perm]) - }, x) - permGridList -} - - -#' Generate one or many permutations of the grid by shuffling -#' the rows, the columns or the whole grid matrix. -#' -#' @title Permute rows, columns or whole grid matrix. -#' @param x `repgrid` object. -#' @param along What to permute. `along=1` (default) will permute the rows -#' `along=2` the columns, `along=3` the whole matrix. -#' @param n The number of permutations to produce. -#' @return A `repgrid` object if `n=1` or a list of -#' `repgrid` objects if `n>1`. -#' @export -#' @keywords internal -#' -#' @examples \dontrun{ -#' -#' # permute grid -#' permuteGrid(bell2010) -#' permuteGrid(bell2010) -#' permuteGrid(bell2010) -#' -#' # generate a list of permuted grids -#' permuteGrid(bell2010, n=5) -#' -#' } -#' -permuteGrid <- function(x, along=1, n=1){ - if (!inherits(x, "repgrid")) - stop("Object must be of class 'repgrid'") - - permuteGridInternal <- function(x, along=1){ - sc <- getRatingLayer(x) - if (along == 1) - res <- t(apply(sc, 1, sample)) - if (along == 2) - res <- apply(sc, 2, sample) - if (along == 0) - res <- sample(sc) - x[,] <- res - x - } - # generate n permuted grids - res <- replicate(n, permuteGridInternal(x=x, along=along)) - # return repgrid object no list if n=1 - if (n == 1) - res <- res[[1]] - res -} - - - -### TODO ### -# Permutation test - -# Slater writes: +######################### Developer's functions ############################## +### Functions that can be used by developers. Often these are ### +### are simple wrappers to access slots of the repgrid object. ### +### They are supposd to facilitate adding new functions for ### +### newcomers to R. ### +### Most functions are documentetd in OpenRepGrid-internal ### +# ////////////////////////////////////////////////////////////////////////////// + + +#' Generate a random grid (quasis) of prompted size. +#' +#' This feature is useful for research purposes like +#' exploring distributions of indexes etc. +#' +#' @param nc Number of constructs (default 10). +#' @param ne Number of elements (default 15). +#' @param nwc Number of random words per construct. +#' @param nwe Number of random words per element. +#' @param range Minimal and maximal scale value (default `c(1, 5)`). +#' @param prob The probability of each rating value to occur. +#' If `NULL` (default) the distribution is uniform. +#' @param options Use random sentences as constructs and elements (1) or +#' not (0). If not, the elements and constructs are given +#' default names and are numbered. +#' @return `repgrid` object. +#' +#' @export +#' @examples \dontrun{ +#' +#' x <- randomGrid() +#' x +#' x <- randomGrid(10, 25) +#' x +#' x <- randomGrid(10, 25, options = 0) +#' x +#' } +#' +randomGrid <- function(nc = 10, ne = 15, nwc = 8, nwe = 5, range = c(1, 5), prob = NULL, options = 1) { + if (options == 1) { # full constructs and element names + elem <- randomSentences(ne, nwe) + left <- randomSentences(nc, nwc) + right <- randomSentences(nc, nwc) + } else { # short element and construct names + elem <- paste("element", seq_len(ne), sep = "") + left <- paste("lconstruct", seq_len(nc), sep = "") + right <- paste("rconstruct", seq_len(nc), sep = "") + } + scores <- sample(range[1]:range[2], nc * ne, + replace = TRUE, prob = prob + ) + args <- list( + name = elem, + l.name = left, + r.name = right, + scores = scores + ) + x <- makeRepgrid(args) + setScale(x, min = range[1], max = range[2], step = 1) +} + + +#' Generate a list of random grids (quasis) of prompted size. +#' +#' This feature is useful for research purposes like +#' exploring distributions of indexes etc. The function is a +#' simple wrapper around [randomGrid()]. +#' +#' @param rep Number of grids to be produced (default is `3`). +#' @param nc Number of constructs (default 10). +#' @param ne Number of elements (default 15). +#' @param nwc Number of random words per construct. +#' @param nwe Number of random words per element. +#' @param range Minimal and maximal scale value (default `c(1, 5)`). +#' @param prob The probability of each rating value to occur. +#' If `NULL` (default) the distribution is uniform. +#' @param options Use random sentences as constructs and elements (1) or +#' not (0). If not, the elements and constructs are given +#' default names and are numbered. +#' @return A list of `repgrid` objects. +#' +#' @export +#' @examples \dontrun{ +#' +#' x <- randomGrids() +#' x +#' x <- randomGrids(5, 3, 3) +#' x +#' x <- randomGrids(5, 3, 3, options = 0) +#' x +#' } +#' +randomGrids <- function(rep = 3, nc = 10, ne = 15, nwc = 8, nwe = 5, + range = c(1, 5), prob = NULL, options = 1) { + replicate(rep, randomGrid( + nc = nc, ne = ne, + nwc = nwc, nwe = nwe, + range = range, prob = prob, + options = options + )) +} + + +#' Generate random grids and calculate 'Slater distances' +#' for the elements. +#' +#' All Slater distances are returned as a vector. The values can be used e.g. to assess the +#' distributions standard deviation. +#' +#' @param rep Number of grids to be produced (default is `3`). +#' @param nc Number of constructs (default 10). +#' @param ne Number of elements (default 15). +#' @param range Minimal and maximal scale value (default `c(1, 5)`). +#' @param prob The probability of each rating value to occur. +#' If `NULL` (default) the distribution is uniform. +#' @param progress Whether to show a progress bar. +#' +#' @return A vector containing Slater distance values. +#' @keywords internal +#' @export +#' @seealso [randomGrids()]; +#' [distanceSlater()]; +#' [distanceHartmann()]. +#' +#' @examples \dontrun{ +#' +#' vals <- quasiDistributionDistanceSlater(100, 10, 10, c(1, 5), pro = T) +#' vals +#' sd(vals) +#' hist(vals, breaks = 50) +#' } +#' +quasiDistributionDistanceSlater <- function(rep, nc, ne, range, prob = NULL, progress = TRUE) { + quasis <- randomGrids(rep, nc = nc, ne = ne, range = range, prob = prob, options = 0) + if (progress) { # whether to show progress bar + lapply_fun <- lapply_pb + } else { + lapply_fun <- lapply + } + quasis.sd <- lapply_fun(quasis, function(x) { + ds <- distanceSlater(x) + ds[lower.tri(ds, diag = FALSE)] + }) + unlist(quasis.sd) # return as vector +} + + +#' Generate a list with all possible construct reflections of a grid. +#' +#' @param x `repgrid` object. +#' @param progress Whether to show a progress bar (default is `TRUE`). +#' This may be sensible for a larger number of elements. +#' @return A list of `repgrid` objects with all possible permutations +#' of the grid. +#' +#' @export +#' @examples \dontrun{ +#' +#' l <- permuteConstructs(mackay1992) +#' l +#' } +#' +permuteConstructs <- function(x, progress = TRUE) { + reflections <- rep(list(0:1), getNoOfConstructs(x)) + perm <- expand.grid(reflections) # all permutations + if (progress) { + apply_used <- apply_pb + } else { + apply_used <- apply + } + permGridList <- apply_used(perm, 1, function(perm, x) { # make grids with all possible reflections + perm <- as.logical(perm) + ncons <- seq_len(getNoOfConstructs(x)) + swapPoles(x, ncons[perm]) + }, x) + permGridList +} + + +#' Generate one or many permutations of the grid by shuffling +#' the rows, the columns or the whole grid matrix. +#' +#' @title Permute rows, columns or whole grid matrix. +#' @param x `repgrid` object. +#' @param along What to permute. `along=1` (default) will permute the rows +#' `along=2` the columns, `along=3` the whole matrix. +#' @param n The number of permutations to produce. +#' @return A `repgrid` object if `n=1` or a list of +#' `repgrid` objects if `n>1`. +#' @export +#' @keywords internal +#' +#' @examples \dontrun{ +#' +#' # permute grid +#' permuteGrid(bell2010) +#' permuteGrid(bell2010) +#' permuteGrid(bell2010) +#' +#' # generate a list of permuted grids +#' permuteGrid(bell2010, n = 5) +#' } +#' +permuteGrid <- function(x, along = 1, n = 1) { + if (!inherits(x, "repgrid")) { + stop("Object must be of class 'repgrid'") + } + + permuteGridInternal <- function(x, along = 1) { + sc <- getRatingLayer(x) + if (along == 1) { + res <- t(apply(sc, 1, sample)) + } + if (along == 2) { + res <- apply(sc, 2, sample) + } + if (along == 0) { + res <- sample(sc) + } + x[, ] <- res + x + } + # generate n permuted grids + res <- replicate(n, permuteGridInternal(x = x, along = along)) + # return repgrid object no list if n=1 + if (n == 1) { + res <- res[[1]] + } + res +} + + + +### TODO ### +# Permutation test + +# Slater writes: diff --git a/R/distance.R b/R/distance.R index 50b22401..55c9dab7 100644 --- a/R/distance.R +++ b/R/distance.R @@ -6,78 +6,84 @@ #' Various distance measures between elements or constructs are calculated. #' #' @param x `repgrid` object. -#' @param along Whether to calculate distance for 1 = constructs (default) +#' @param along Whether to calculate distance for 1 = constructs (default) #' or for 2= elements. -#' @param dmethod The distance measure to be used. This must be one of -#' "euclidean", "maximum", "manhattan", "canberra", "binary" -#' or "minkowski". Any unambiguous substring can be given. +#' @param dmethod The distance measure to be used. This must be one of +#' "euclidean", "maximum", "manhattan", "canberra", "binary" +#' or "minkowski". Any unambiguous substring can be given. #' For additional information on the different types type -#' `?dist`. +#' `?dist`. #' @param p The power of the Minkowski distance, in case `"minkowski"` #' is used as argument for `dmethod`. -#' @param normalize Use normalized distances. The distances are divided by the -#' highest possible value given the rating scale fo the grid, +#' @param normalize Use normalized distances. The distances are divided by the +#' highest possible value given the rating scale fo the grid, #' so all distances are in the interval `[0,1]`. #' @param trim The number of characters a construct or element is trimmed to (default is #' `20`). If `NA` no trimming occurs. Trimming #' simply saves space when displaying correlation of constructs #' with long names. -#' @param index Whether to print the number of the construct or element +#' @param index Whether to print the number of the construct or element #' in front of the name (default is `TRUE`). This is useful to avoid #' identical row names, which may cause an error. #' @param ... Additional parameters to be passed to function `dist`. -#' Type `dist` for further information. +#' Type `dist` for further information. #' @return `matrix` object. #' @export #' @examples #' -#' # between constructs -#' distance(bell2010, along = 1) -#' distance(bell2010, along = 1, normalize = TRUE) -#' -#' # between elements -#' distance(bell2010, along = 2) -#' -#' # several distance methods -#' distance(bell2010, dm = "man") # manhattan distance -#' distance(bell2010, dm = "mink", p = 3) # minkowski metric to the power of 3 -#' -#' # to save the results without printing to the console -#' d <- distance(bell2010, trim = 7) -#' d -#' -#' # some more options when printing the distance matrix -#' print(d, digits = 5) -#' print(d, col.index = FALSE) -#' print(d, upper = FALSE) -#' -#' # accessing entries from the matrix -#' d[1,3] -#' -distance <- function(x, along = 1, dmethod = "euclidean", - p = 2, normalize = FALSE, trim = 20, index = TRUE, ...) { - dmethods <- c("euclidean", "maximum", "manhattan", # possible distance methods - "canberra", "binary", "minkowski") - dmethod <- match.arg(dmethod, dmethods) # match method - if (!inherits(x, "repgrid")) # check if x is repgrid object +#' # between constructs +#' distance(bell2010, along = 1) +#' distance(bell2010, along = 1, normalize = TRUE) +#' +#' # between elements +#' distance(bell2010, along = 2) +#' +#' # several distance methods +#' distance(bell2010, dm = "man") # manhattan distance +#' distance(bell2010, dm = "mink", p = 3) # minkowski metric to the power of 3 +#' +#' # to save the results without printing to the console +#' d <- distance(bell2010, trim = 7) +#' d +#' +#' # some more options when printing the distance matrix +#' print(d, digits = 5) +#' print(d, col.index = FALSE) +#' print(d, upper = FALSE) +#' +#' # accessing entries from the matrix +#' d[1, 3] +#' +distance <- function(x, along = 1, dmethod = "euclidean", + p = 2, normalize = FALSE, trim = 20, index = TRUE, ...) { + dmethods <- c( + "euclidean", "maximum", "manhattan", # possible distance methods + "canberra", "binary", "minkowski" + ) + dmethod <- match.arg(dmethod, dmethods) # match method + if (!inherits(x, "repgrid")) { # check if x is repgrid object stop("Object x must be of class 'repgrid'") - + } + r <- getRatingLayer(x, trim = trim) - if (along == 2) + if (along == 2) { r <- t(r) + } d <- dist(r, method = dmethod, p = p, ...) - d <- as.matrix(d) - d <- addNamesToMatrix2(x, d, index = index, trim = trim, along = along) - class(d) <- c("distance", "matrix") - attr(d, "arguments") <- list(along = along, dmethod = dmethod, p = p, - notes = NULL, cutoff = NULL, - normalize = normalize) + d <- as.matrix(d) + d <- addNamesToMatrix2(x, d, index = index, trim = trim, along = along) + class(d) <- c("distance", "matrix") + attr(d, "arguments") <- list( + along = along, dmethod = dmethod, p = p, + notes = NULL, cutoff = NULL, + normalize = normalize + ) # normalize distances if (normalize) { mx <- dist_minmax(x, along = along, dmethod = dmethod, p = p, max.only = TRUE) d <- d / mx } - + return(d) } @@ -86,90 +92,95 @@ distance <- function(x, along = 1, dmethod = "euclidean", #' #' While the minimal distance will usually be zero, the maximal distance can be used to normalize arbitrary distances. #' @keywords internal -#' +#' dist_minmax <- function(x, along = 1, dmethod = "euclidean", p = 2, max.only = FALSE) { R <- ratings(x) # constructs = 1, elements = 2 if (along == 2) { R <- t(R) - } + } r3 <- r2 <- r1 <- R[1, , drop = FALSE] # make it work with single constructs or element sc <- getScale(x) - r1[ , ] <- sc["min"] - r2[ , ] <- sc["min"] - r3[ , ] <- sc["max"] + r1[, ] <- sc["min"] + r2[, ] <- sc["min"] + r3[, ] <- sc["max"] r <- rbind(r1, r2, r3) d <- dist(r, method = dmethod, p = p) minmax <- range(as.vector(d)) - if (max.only) + if (max.only) { return(minmax[2]) + } minmax } #' Print method for class distance. -#' +#' #' @param x Object of class distance. -#' @param digits Numeric. Number of digits to round to (default is +#' @param digits Numeric. Number of digits to round to (default is #' `2`). -#' @param col.index Logical. Whether to add an extra index column so the -#' column names are indexes instead of construct names. This option -#' renders a neater output as long construct names will stretch +#' @param col.index Logical. Whether to add an extra index column so the +#' column names are indexes instead of construct names. This option +#' renders a neater output as long construct names will stretch #' the output (default is `TRUE`). -#' @param upper Whether to display upper triangle of correlation matrix only +#' @param upper Whether to display upper triangle of correlation matrix only #' (default is `TRUE`). -#' @param cutoffs Cutoff values. Values below or above this interval are not -#' printed. For Slater distances `c(.8, 1.2)` are common +#' @param cutoffs Cutoff values. Values below or above this interval are not +#' printed. For Slater distances `c(.8, 1.2)` are common #' values. -#' @param diag Whether to show the matrix diagonal. +#' @param diag Whether to show the matrix diagonal. #' @param ... Not evaluated. #' @export #' @method print distance #' @keywords internal #' print.distance <- function(x, digits = 2, col.index = TRUE, - upper = TRUE, diag = FALSE, cutoffs = NA, ...) -{ - diag <- !diag # convert as used in upper.tri + upper = TRUE, diag = FALSE, cutoffs = NA, ...) { + diag <- !diag # convert as used in upper.tri args <- attr(x, "arguments") d <- x - class(d) <- "matrix" - d <- round(d, digits) - e <- format(d, nsmall = digits) # convert to characters for printing - - ## console output ## - blank <- paste(rep(" ", max(nchar(as.vector(e)))), collapse = "", sep = "") - + class(d) <- "matrix" + d <- round(d, digits) + e <- format(d, nsmall = digits) # convert to characters for printing + + ## console output ## + blank <- paste(rep(" ", max(nchar(as.vector(e)))), collapse = "", sep = "") + # remove values above or below explicit cutoff - if (!is.na(cutoffs[1])) { + if (!is.na(cutoffs[1])) { n.s. <- min(cutoffs) < d & d < max(cutoffs) - e[n.s.] <- blank + e[n.s.] <- blank } - - if (upper) + + if (upper) { e[lower.tri(e, diag = diag)] <- blank + } # make index column for neater colnames - if (col.index) - e <- addIndexColumnToMatrix(e) else - colnames(e) <- seq_len(ncol(e)) + if (col.index) { + e <- addIndexColumnToMatrix(e) + } else { + colnames(e) <- seq_len(ncol(e)) + } e <- as.data.frame(e) - if (args$along == 1) { + if (args$along == 1) { cat("\n############################") - cat("\nDistances between constructs") + cat("\nDistances between constructs") cat("\n############################") } else if (args$along == 2) { cat("\n##########################") - cat("\nDistances between elements") + cat("\nDistances between elements") cat("\n##########################") } cat("\n\nDistance method: ", args$dmethod) - if (args$dmethod == "minkowski") + if (args$dmethod == "minkowski") { cat("\nPower p:", args$p) + } cat("\nNormalized:", args$normalize) cat("\n") - print(e) - if (!is.null(args$notes)) + print(e) + if (!is.null(args$notes)) { cat(args$notes) + } cat("\n") } @@ -177,22 +188,22 @@ print.distance <- function(x, digits = 2, col.index = TRUE, #### Slater distance #### #' Internal workhorse for Slater standardization. -#' +#' #' Function uses a matrix as input. All overhead #' of `repgrid` class is avoided. Needed for speedy simulations. #' #' @param x A matrix. #' @keywords internal #' @export -#' +#' slaterStandardization <- function(x) { - E <- dist(t(x), diag=TRUE, upper=TRUE) # euclidean distance + E <- dist(t(x), diag = TRUE, upper = TRUE) # euclidean distance E <- as.matrix(E) - m <- ncol(x) # number of elements - D <- sweep(x, 1, apply(x, 1, mean)) # row-center data + m <- ncol(x) # number of elements + D <- sweep(x, 1, apply(x, 1, mean)) # row-center data S <- sum(diag(t(D) %*% D)) - U <- (2 * S/(m - 1))^0.5 - E/U # divide by expected distance unit + U <- (2 * S / (m - 1))^0.5 + E / U # divide by expected distance unit } @@ -209,17 +220,17 @@ slaterStandardization <- function(x) { #' Slater distances is asymmetric. Hence, the upper and lower limit to infer 'significance' of distance is not #' symmetric. The practical relevance of Hartmann's findings have been demonstrated by Schoeneich and Klapp (1998). To #' calculate Hartmann's version of the standardized distances see [distanceHartmann()] -#' -#' @section Calculation: The Slater distance is calculated as follows. +#' +#' @section Calculation: The Slater distance is calculated as follows. #' For a derivation see Slater (1977, p.94). \cr #' Let matrix \eqn{D}{D} contain the row centered ratings. Then #' \deqn{P = D^TD}{P = D^TD} and #' \deqn{S = tr(P)}{S = tr(P)} #' The expected 'unit of expected distance' results as \cr -#' \deqn{U = (2S/(m-1))^{1/2}}{U = (2S/(m-1))^.5} +#' \deqn{U = (2S/(m-1))^{1/2}}{U = (2S/(m-1))^.5} #' where \eqn{m}{m} denotes the number of elements of the grid. #' The standardized Slater distances is the matrix of Euclidean distances -#' \eqn{E}{E} divided by the expected distance \eqn{U}{U}. +#' \eqn{E}{E} divided by the expected distance \eqn{U}{U}. #' \deqn{E/U}{E/U} #' #' @inheritParams distance @@ -235,27 +246,32 @@ slaterStandardization <- function(x) { #' Slater, P. (1977). *The measurement of intrapersonal space by Grid technique.* Vol. II. London: Wiley. #' @export #' @seealso [distanceHartmann()] -#' @examples -#' -#' distanceSlater(bell2010) -#' distanceSlater(bell2010, trim=40) -#' -#' d <- distanceSlater(bell2010) -#' print(d) -#' print(d, digits=4) -#' -#' # using Norris and Makhlouf-Norris (problematic) cutoffs -#' print(d, cutoffs=c(.8, 1.2)) -#' -distanceSlater <- function(x, trim=20, index=TRUE) { - if (!inherits(x, "repgrid")) - stop("Object must be of class 'repgrid'") - E <- distance(x, along=2, index=index) +#' @examples +#' +#' distanceSlater(bell2010) +#' distanceSlater(bell2010, trim = 40) +#' +#' d <- distanceSlater(bell2010) +#' print(d) +#' print(d, digits = 4) +#' +#' # using Norris and Makhlouf-Norris (problematic) cutoffs +#' print(d, cutoffs = c(.8, 1.2)) +#' +distanceSlater <- function(x, trim = 20, index = TRUE) { + if (!inherits(x, "repgrid")) { + stop("Object must be of class 'repgrid'") + } + E <- distance(x, along = 2, index = index) E.sl <- slaterStandardization(E) - notes <- c("\nNote that Slater distances cannot be compared across grids", - "with a different number of constructs (see Hartmann, 1992).\n") - attr(E.sl, "arguments") <- list(along=2, dmethod="Slater (standardized Euclidean)", - p=2, notes=notes) + notes <- c( + "\nNote that Slater distances cannot be compared across grids", + "with a different number of constructs (see Hartmann, 1992).\n" + ) + attr(E.sl, "arguments") <- list( + along = 2, dmethod = "Slater (standardized Euclidean)", + p = 2, notes = notes + ) class(E.sl) <- c("distance", "matrix") E.sl } @@ -265,31 +281,28 @@ distanceSlater <- function(x, trim=20, index=TRUE) { # helper functions for Slater distribution simulation # -generate_quasi <- function(nc=5, ne=10, r=1:5, prob= rep(1, length(r))) -{ - matrix(sample(r, size=nc*ne, replace=T, prob=prob), ncol=ne) +generate_quasi <- function(nc = 5, ne = 10, r = 1:5, prob = rep(1, length(r))) { + matrix(sample(r, size = nc * ne, replace = T, prob = prob), ncol = ne) } -generate_quasis <- function(n, nc=5, ne=10, r=1:5, prob= rep(1, length(r))) -{ - replicate(n, generate_quasi(nc=nc, ne=ne, r=r, prob=prob), simplify=FALSE) +generate_quasis <- function(n, nc = 5, ne = 10, r = 1:5, prob = rep(1, length(r))) { + replicate(n, generate_quasi(nc = nc, ne = ne, r = r, prob = prob), simplify = FALSE) } -get_upper_triangle <- function(x) -{ - x[upper.tri(x, diag=FALSE)] +get_upper_triangle <- function(x) { + x[upper.tri(x, diag = FALSE)] } -quasiDistributionDistanceSlater <- function(reps, nc, ne, range, - prob=NULL, progress=TRUE) -{ - q <- generate_quasis(reps, nc=nc, ne=ne, r=range, prob= NULL) +quasiDistributionDistanceSlater <- function(reps, nc, ne, range, + prob = NULL, progress = TRUE) { + q <- generate_quasis(reps, nc = nc, ne = ne, r = range, prob = NULL) fun <- lapply - if (progress) - fun <- lapply_pb + if (progress) { + fun <- lapply_pb + } dist.sl <- fun(q, slaterStandardization) dist.sl <- lapply(dist.sl, get_upper_triangle) unlist(dist.sl) @@ -312,68 +325,80 @@ quasiDistributionDistanceSlater <- function(reps, nc, ne, range, # Return a list with the mean and sd as indicated in Hartmann's (1992) paper. -# -getSlaterPaperPars <- function(nc) -{ - constructs <- NULL # dummy to avoid R CMD CHECK non-visible variable binding NOTE - +# +getSlaterPaperPars <- function(nc) { + constructs <- NULL # dummy to avoid R CMD CHECK non-visible variable binding NOTE + # hartmann only provides values for a number of constructs between 7 and 21. # Smaller and bigger grids use the parameters with the next best number of # constructs from Hartmann - if (nc < 7) + if (nc < 7) { nc <- 7 - if (nc > 21) + } + if (nc > 21) { nc <- 21 - + } + ## constants ## # parameters for Slater distance distributions used to calculated Hartmann # distances as supplied by Hartmann, 1992, p. 51. (only defined for 7 to 21 # constructs) # - hartmann.pars <- data.frame(constructs=7:21, - mean=c(.97596, .97902, 0.98236, .98322, .98470, - .98643, .98749, .98811, .98908, .98972, - .99034, .99092, .99135, .99193, .99228), - sd=c(.21910, .20376, .19211, .18240, .17396, .16416, .15860, .15374, .14700, - .14303, .13832, .13444, .13082, .12676, .12365)) - + hartmann.pars <- data.frame( + constructs = 7:21, + mean = c( + .97596, .97902, 0.98236, .98322, .98470, + .98643, .98749, .98811, .98908, .98972, + .99034, .99092, .99135, .99193, .99228 + ), + sd = c( + .21910, .20376, .19211, .18240, .17396, .16416, .15860, .15374, .14700, + .14303, .13832, .13444, .13082, .12676, .12365 + ) + ) + # "Therefore the means of all Z-transformed percentiles [avering three scale # range, MH] are suggested to be used as cutoffs for distance interpretation. # The use of the 5th and the 95th percentiles is recommended (see Table 5)" # (Hartmann, 1992, p.52). - # - hartmann.cutoffs <- c(p01=2.492, p05=1.777, p10=1.387, - p90=-1.186, p95=- 1.519, p99=- 2.129) + # + hartmann.cutoffs <- c( + p01 = 2.492, p05 = 1.777, p10 = 1.387, + p90 = -1.186, p95 = -1.519, p99 = -2.129 + ) slater.mean <- unlist(subset(hartmann.pars, constructs == nc, mean)) slater.sd <- unlist(subset(hartmann.pars, constructs == nc, sd)) - list(mean=slater.mean, sd=slater.sd) + list(mean = slater.mean, sd = slater.sd) } -simulateSlaterAndHartmannDistribution <- function(reps=1000, nc, ne, range, - prob=NULL, - progress=TRUE) -{ +simulateSlaterAndHartmannDistribution <- function(reps = 1000, nc, ne, range, + prob = NULL, + progress = TRUE) { # this operation takes some time - slater.vals <- quasiDistributionDistanceSlater(reps=reps, nc=nc, - ne=ne, range=range, - prob=prob, - progress=progress) + slater.vals <- quasiDistributionDistanceSlater( + reps = reps, nc = nc, + ne = ne, range = range, + prob = prob, + progress = progress + ) # mean and sd of Slater distribution - mean.slater <- mean(slater.vals, na.rm=TRUE) - sd.slater <- sd(slater.vals, na.rm=TRUE) - + mean.slater <- mean(slater.vals, na.rm = TRUE) + sd.slater <- sd(slater.vals, na.rm = TRUE) + # conversion to Hartmann values - hartmann.vals <- -1 * (slater.vals - mean.slater) / sd.slater - list(slater = slater.vals, - hartmann = hartmann.vals) + hartmann.vals <- -1 * (slater.vals - mean.slater) / sd.slater + list( + slater = slater.vals, + hartmann = hartmann.vals + ) } # NOT USED -# # caclulate coverage probability_ +# # caclulate coverage probability_ # coverageProbability <- function(x, cutoffs) -# { +# { # l <- length(x) # oneCoverProb <- function(cutoff) # sum(x < cutoff) / l @@ -381,13 +406,12 @@ simulateSlaterAndHartmannDistribution <- function(reps=1000, nc, ne, range, # } -getDistributionParameters <- function(x, probs=c(.01, .025, .05, .1, .9, .95, .975, .99), - na.rm=TRUE) -{ +getDistributionParameters <- function(x, probs = c(.01, .025, .05, .1, .9, .95, .975, .99), + na.rm = TRUE) { pars <- describe(x) qs <- quantile(x, probs = probs, na.rm = na.rm) - #cover.probs <- coverageProbability(x, cutoffs) # get coverage probabalities for cutoffs - list(pars=pars, quantiles=qs) + # cover.probs <- coverageProbability(x, cutoffs) # get coverage probabalities for cutoffs + list(pars = pars, quantiles = qs) } @@ -411,26 +435,26 @@ getDistributionParameters <- function(x, probs=c(.01, .025, .05, .1, .9, .95, .9 #' #' #' @section Calculation: -#' +#' #' The 'Hartmann distance' is calculated as follows (Hartmann 1992, p. 49). \cr #' \deqn{D = -1 (\frac{D_{slater} - M_c}{sd_c})}{D = -1 (D_slater - M_c / sd_c)} #' Where \eqn{D_{slater}}{D_slater} denotes the Slater distances of the grid, -#' \eqn{M_c}{M_c} the sample distribution's mean value and +#' \eqn{M_c}{M_c} the sample distribution's mean value and #' \eqn{sd_c}{sd_c} the sample distribution's standard deviation. #' #' @title 'Hartmann distance' (standardized Slater distances). #' @param x `repgrid` object. -#' @param method The method used for distance calculation, on of -#' `"paper", "simulate", "new"`. `"paper"` uses the +#' @param method The method used for distance calculation, on of +#' `"paper", "simulate", "new"`. `"paper"` uses the #' parameters as given in Hartmann (1992) for calculation. #' `"simulate"` (default) simulates a Slater distribution #' for the calculation. In a future version the time consuming #' simulation will be replaced by more accurate parameters for -#' Hartmann distances than used in Hartmann (1992). -#' @param reps Number of random grids to generate sample distribution for +#' Hartmann distances than used in Hartmann (1992). +#' @param reps Number of random grids to generate sample distribution for #' Slater distances (default is `10000`). Note that #' a lot of samples may take a while to calculate. -#' @param prob The probability of each rating value to occur. +#' @param prob The probability of each rating value to occur. #' If `NULL` (default) the distribution is uniform. #' The number of values must match the length of the rating scale. #' @param progress Whether to show a progress bar during simulation @@ -440,113 +464,123 @@ getDistributionParameters <- function(x, probs=c(.01, .025, .05, .1, .9, .95, .9 #' @param distributions Whether to additionally return the values of the simulated #' distributions (Slater etc.) The default is `FALSE` #' as it will quickly boost the object size. -#' @return A matrix containing Hartmann distances. In the attributes several additional parameters can be found: -#' +#' @return A matrix containing Hartmann distances. In the attributes several additional parameters can be found: +#' #' - `arguments`: A list of several parameters including `mean` and `sd` of Slater distribution. #' - `quantiles`: Quantiles for Slater and Hartmann distance distribution. #' - `distributions`: List with values of the simulated distributions. -#' +#' #' @references Hartmann, A. (1992). Element comparisons in repertory grid technique: Results and consequences of a #' Monte Carlo study. *International Journal of Personal Construct Psychology, 5*(1), 41-56. #' @export #' @seealso [distanceSlater()] #' @examples \dontrun{ #' -#' ### basics ### -#' -#' distanceHartmann(bell2010) -#' distanceHartmann(bell2010, method="simulate") -#' h <- distanceHartmann(bell2010, method="simulate") -#' h -#' -#' # printing options -#' print(h) -#' print(h, digits=6) -#' # 'significant' distances only -#' print(h, p=c(.05, .95)) -#' -#' # access cells of distance matrix -#' h[1,2] -#' -#' ### advanced ### -#' -#' # histogram of Slater distances and indifference region -#' h <- distanceHartmann(bell2010, distributions=TRUE) -#' l <- attr(h, "distributions") -#' hist(l$slater, breaks=100) -#' hist(l$hartmann, breaks=100) +#' ### basics ### +#' +#' distanceHartmann(bell2010) +#' distanceHartmann(bell2010, method = "simulate") +#' h <- distanceHartmann(bell2010, method = "simulate") +#' h +#' +#' # printing options +#' print(h) +#' print(h, digits = 6) +#' # 'significant' distances only +#' print(h, p = c(.05, .95)) +#' +#' # access cells of distance matrix +#' h[1, 2] +#' +#' ### advanced ### +#' +#' # histogram of Slater distances and indifference region +#' h <- distanceHartmann(bell2010, distributions = TRUE) +#' l <- attr(h, "distributions") +#' hist(l$slater, breaks = 100) +#' hist(l$hartmann, breaks = 100) #' } -#' -distanceHartmann <- function(x, method="paper", reps=10000, - prob=NULL, progress=TRUE, distributions=FALSE) { +#' +distanceHartmann <- function(x, method = "paper", reps = 10000, + prob = NULL, progress = TRUE, distributions = FALSE) { if (distributions == TRUE & method != "simulate") { method <- "simulate" - warning("'method' set to 'simulate' to return distributions", call.=FALSE) + warning("'method' set to 'simulate' to return distributions", call. = FALSE) } - if (!inherits(x, "repgrid")) + if (!inherits(x, "repgrid")) { stop("Object must be of class 'repgrid'") - ps <- seq(0, 1, .001) # probabilty for quantiles to return - + } + ps <- seq(0, 1, .001) # probabilty for quantiles to return + # select parameter derivation for transformation method <- match.arg(method, c("paper", "simulate", "new")) - ## get grid parameters ## - mm <- getScale(x) # get min and max scale value + ## get grid parameters ## + mm <- getScale(x) # get min and max scale value range <- mm[1]:mm[2] nc <- getNoOfConstructs(x) ne <- getNoOfElements(x) - + # derive parameters mean and sd by simulation of Slater distance distributions # for given grid size if (method == "simulate") { - v <- simulateSlaterAndHartmannDistribution(reps=reps, nc=nc, ne=ne, range=range, - prob=prob, progress=progress) + v <- simulateSlaterAndHartmannDistribution( + reps = reps, nc = nc, ne = ne, range = range, + prob = prob, progress = progress + ) sl <- getDistributionParameters(v$slater) - hm <- getDistributionParameters(v$hartmann) + hm <- getDistributionParameters(v$hartmann) } - - # use parameters mean and sd from Hartmann paper or simulated + + # use parameters mean and sd from Hartmann paper or simulated # TODO: use my own simulated parameters with bigger sample size # for more accuracy than Hartmann. This will give accurate results # while still avoiding time-consuming simulations. notes <- NULL if (method == "paper") { - p <- getSlaterPaperPars(nc) - notes <- c("\nFor calculation the parameters from Hartmann (1992) were used.", - "Use 'method=new' or method='simulate' for a more accurate version.\n") - } else - if (method == "simulate") - p <- list(mean=sl$pars$mean, sd=sl$pars$sd) else - if (method == "new") - stop("method 'new' has not yet been implemented", call.=FALSE) else - stop("'method' must be 'paper', 'simulate' or 'new'", call.=FALSE) - - # linear transformation to derive Hartmann distance from Slater distances + p <- getSlaterPaperPars(nc) + notes <- c( + "\nFor calculation the parameters from Hartmann (1992) were used.", + "Use 'method=new' or method='simulate' for a more accurate version.\n" + ) + } else if (method == "simulate") { + p <- list(mean = sl$pars$mean, sd = sl$pars$sd) + } else if (method == "new") { + stop("method 'new' has not yet been implemented", call. = FALSE) + } else { + stop("'method' must be 'paper', 'simulate' or 'new'", call. = FALSE) + } + + # linear transformation to derive Hartmann distance from Slater distances # (Hartmman, 1992, p. 49) D <- distanceSlater(x) H <- -1 * (D - p$mean) / p$sd - #diag(H) <- 0 # replace diagonal as zeros (Hmmm?) - + # diag(H) <- 0 # replace diagonal as zeros (Hmmm?) + # prepare output - attr(H, "arguments") <- list(along=2, dmethod="Hartmann (standardized Slater distances)", p=2, - notes=notes, - parameters=p, - method=method) + attr(H, "arguments") <- list( + along = 2, dmethod = "Hartmann (standardized Slater distances)", p = 2, + notes = notes, + parameters = p, + method = method + ) if (method == "simulate") { - quantiles.slater <- quantile(v$slater, probs=ps) - quantiles.hartmann <- quantile(v$hartmann, probs=ps) + quantiles.slater <- quantile(v$slater, probs = ps) + quantiles.hartmann <- quantile(v$hartmann, probs = ps) } else { quantiles.slater <- NULL quantiles.hartmann <- NULL } - - attr(H, "quantiles") <- list(slater=quantiles.slater, - hartmann=quantiles.hartmann) + + attr(H, "quantiles") <- list( + slater = quantiles.slater, + hartmann = quantiles.hartmann + ) # return Slater and Hartmann simulated distribution values if requested # caution: objects get quite big ~ 6mb with 10000 reps - if (distributions){ - attr(H, "distributions") <- v - } + if (distributions) { + attr(H, "distributions") <- v + } class(H) <- c("hdistance", "distance", "matrix") H } @@ -567,39 +601,45 @@ distanceHartmann <- function(x, method="paper", reps=10000, #' @export #' @method print hdistance #' @keywords internal -print.hdistance <- function(x, digits=2, col.index=TRUE, - upper=TRUE, diag=FALSE, cutoffs=NA, - p=NA, ...) { +print.hdistance <- function(x, digits = 2, col.index = TRUE, + upper = TRUE, diag = FALSE, cutoffs = NA, + p = NA, ...) { # only calculate quantiles when they are supplied in the object. # this is currently only the case for method="simulate". Will change # when bigger simulations are finished. do.quantiles <- FALSE - if (attr(x, "arguments")$method == "simulate") + if (attr(x, "arguments")$method == "simulate") { do.quantiles <- TRUE - + } + # select quantiles to use (Hartmann or Power-transformed Hartmann distances) - dmethod <- attr(x, "arguments")$dmethod - if (dmethod == "Hartmann (standardized Slater distances)") - dm <- "hartmann" else dm <- "bc" - + dmethod <- attr(x, "arguments")$dmethod + if (dmethod == "Hartmann (standardized Slater distances)") { + dm <- "hartmann" + } else { + dm <- "bc" + } + # calculate quantiles (cutoff values) from lowest and biggest p value. get - # quantiles from distance object (only for Hartmann distance). not the best + # quantiles from distance object (only for Hartmann distance). not the best # approach, maybe change this in the future to use a lookup table when solid # cutoffs are available. - if (!is.na(p[1]) & do.quantiles) { - which.p <- round(seq(0, 1, .001), 6) %in% round(p, 6) # to avoid floating number representation inequalities - qs <- attr(x, "quantiles")[[dm]][which.p] + if (!is.na(p[1]) & do.quantiles) { + which.p <- round(seq(0, 1, .001), 6) %in% round(p, 6) # to avoid floating number representation inequalities + qs <- attr(x, "quantiles")[[dm]][which.p] cutoffs <- qs } - + # call standard printing function for distance objects - print.distance(x=x, digits=digits, col.index=col.index, upper=upper, - diag=diag, cutoffs=cutoffs) - + print.distance( + x = x, digits = digits, col.index = col.index, upper = upper, + diag = diag, cutoffs = cutoffs + ) + # add quantiles used as cutoffs if (!is.na(p[1]) & do.quantiles) { cat("Quantiles:\n") - print(round(qs, 4)) + print(round(qs, 4)) cat("\nThe smallest and biggest quantiles are used as cutoffs.\n") } } @@ -612,7 +652,7 @@ print.hdistance <- function(x, digits=2, col.index=TRUE, #' #' Hartmann (1992) suggested a transformation of Slater (1977) distances to make #' them independent from the size of a grid. Hartmann distances are supposed to -#' yield stable cutoff values used to determine 'significance' of inter-element +#' yield stable cutoff values used to determine 'significance' of inter-element #' distances. It can be shown that Hartmann distances are still affected by grid #' parameters like size and the range of the rating scale used (Heckmann, 2012). #' The function `distanceNormalize` applies a Box-Cox (1964) transformation to the @@ -620,11 +660,11 @@ print.hdistance <- function(x, digits=2, col.index=TRUE, #' distribution. The normalized values show to have more stable cutoffs #' (quantiles) and better properties for comparison across grids of different #' size and scale range. \cr -#' +#' #' The function `distanceNormalize` can also return #' the quantiles of the sample distribution and only the element distances #' considered 'significant' according to the quantiles defined. -#' +#' #' @section Calculations: #' The 'power transformed Hartmann distance' are calculated as #' follows: The simulated Hartmann distribution is added a constant as the @@ -635,26 +675,26 @@ print.hdistance <- function(x, digits=2, col.index=TRUE, #' normality is used to transform Hartmann distances. As the resulting scale of #' the power transformation depends on lambda, the resulting values are #' z-transformed to derive a common scaling. -#' -#' The code for the calculation of the optimal lambda was written by Ioannis +#' +#' The code for the calculation of the optimal lambda was written by Ioannis #' Kosmidis. #' #' @param x `repgrid` object. #' @param reps Number of random grids to generate to produce #' sample distribution for Hartmann distances #' (default is `1000`). Note that -#' a lot of samples may take a while to calculate. +#' a lot of samples may take a while to calculate. #' @inheritParams distanceHartmann #' #' @return A matrix containing the standardized distances. \cr -#' Further data is contained in the object's attributes: \cr -#' \item{`"arguments"`}{A list of several parameters +#' Further data is contained in the object's attributes: \cr +#' \item{`"arguments"`}{A list of several parameters #' including `mean` and `sd` of Slater distribution.} -#' \item{`"quantiles"`}{Quantiles for Slater, Hartmann +#' \item{`"quantiles"`}{Quantiles for Slater, Hartmann #' and power transformed distance distributions.} -#' \item{`"distributions"`}{List with values of the +#' \item{`"distributions"`}{List with values of the #' simulated distributions, if `distributions=TRUE`.} -#' +#' #' @references Box, G. E. P., & Cox, D. R. (1964). An Analysis of Transformations. #' *Journal of the Royal Statistical Society. Series B (Methodological), 26*(2), 211-252. #' @@ -666,83 +706,80 @@ print.hdistance <- function(x, digits=2, col.index=TRUE, #' July 2012. #' #' Slater, P. (1977). *The measurement of intrapersonal space by Grid technique*. London: Wiley. -#' +#' #' @export #' @seealso [distanceHartmann()] and [distanceSlater()]. #' @examples \dontrun{ #' -#' ### basics ### -#' -#' distanceNormalized(bell2010) -#' n <- distanceNormalized(bell2010) -#' n -#' -#' # printing options -#' print(n) -#' print(n, digits=4) -#' # 'significant' distances only -#' print(n, p=c(.05, .95)) -#' -#' # access cells of distance matrix -#' n[1,2] -#' -#' ### advanced ### -#' -#' # histogram of Slater distances and indifference region -#' n <- distanceNormalized(bell2010, distributions=TRUE) -#' l <- attr(n, "distributions") -#' hist(l$bc, breaks=100) -#' +#' ### basics ### +#' +#' distanceNormalized(bell2010) +#' n <- distanceNormalized(bell2010) +#' n +#' +#' # printing options +#' print(n) +#' print(n, digits = 4) +#' # 'significant' distances only +#' print(n, p = c(.05, .95)) +#' +#' # access cells of distance matrix +#' n[1, 2] +#' +#' ### advanced ### +#' +#' # histogram of Slater distances and indifference region +#' n <- distanceNormalized(bell2010, distributions = TRUE) +#' l <- attr(n, "distributions") +#' hist(l$bc, breaks = 100) #' } #' -distanceNormalized <- function(x, reps=1000, prob=NULL, progress=TRUE, - distributions=TRUE) -{ - if (!inherits(x, "repgrid")) +distanceNormalized <- function(x, reps = 1000, prob = NULL, progress = TRUE, + distributions = TRUE) { + if (!inherits(x, "repgrid")) { stop("Object must be of class 'repgrid'") - - ps <- seq(0, 1, .001) # probabilty for quantiles to return - + } + + ps <- seq(0, 1, .001) # probabilty for quantiles to return + # calculate Hartmann and Slater distances - h <- distanceHartmann(x, reps=reps, prob=prob, progress=progress, - method="simulate", distributions=distributions) - - # optimal lambda for Box-Cox transformation. Add constant as only defined + h <- distanceHartmann(x, + reps = reps, prob = prob, progress = progress, + method = "simulate", distributions = distributions + ) + + # optimal lambda for Box-Cox transformation. Add constant as only defined # for positive values. Use offest 1 for same treatment of tails. d <- attr(h, "distributions") - constant <- abs(min(c(d$hartmann, h))) + 1.00001 - bc <- optimal.boxcox(d$hartmann + constant) - + constant <- abs(min(c(d$hartmann, h))) + 1.00001 + bc <- optimal.boxcox(d$hartmann + constant) + # parameters to standardize power transformed Hartmann values lambda.max <- bc$lambda sd.bc <- sd(bc$x) mean.bc <- mean(bc$x) - + # function to perform Box-Cox tranformation plus standardization - bc.transform <- function(x){ # , constant, lambda.max, sd.bc, mean.bc){ - res <- ((x + constant)^lambda.max - 1) / lambda.max # power transformation - (res-mean.bc) / (sd.bc) # z-transformation + bc.transform <- function(x) { # , constant, lambda.max, sd.bc, mean.bc){ + res <- ((x + constant)^lambda.max - 1) / lambda.max # power transformation + (res - mean.bc) / (sd.bc) # z-transformation } - + # make bc transformations for all Hartmann data - bc.dist <- bc.transform(d$hartmann) # transform simulated Hartmann distribution - bc.vals <- bc.transform(h) # transform grid data - bc.qs <- quantile(bc.dist, ps, na.rm=TRUE) - + bc.dist <- bc.transform(d$hartmann) # transform simulated Hartmann distribution + bc.vals <- bc.transform(h) # transform grid data + bc.qs <- quantile(bc.dist, ps, na.rm = TRUE) + # prepare output notes <- NULL - l <- list(dmethod="Power transformed Hartmann distances", notes=notes) + l <- list(dmethod = "Power transformed Hartmann distances", notes = notes) attr(h, "arguments") <- modifyList(attr(h, "arguments"), l) - + # add distribution of power-transformed values - if (distributions) + if (distributions) { attr(h, "distributions")$bc <- bc.dist + } # add quantiles of power-transformed values attr(h, "quantiles")$bc <- bc.qs h } - - - - - diff --git a/R/double-entry.R b/R/double-entry.R index e390e9c8..62c59c50 100644 --- a/R/double-entry.R +++ b/R/double-entry.R @@ -1,14 +1,16 @@ - #### class for decoupled grids #### -setClass( "doubleEntry", - representation( meta = "list", - scale = "list", - coupled = "logical", - elements = "list", - constructs = "list", - elicitation = "list", - ratings = "array", - calcs = "list", - plotdata = "data.frame")) - +setClass( + "doubleEntry", + representation( + meta = "list", + scale = "list", + coupled = "logical", + elements = "list", + constructs = "list", + elicitation = "list", + ratings = "array", + calcs = "list", + plotdata = "data.frame" + ) +) diff --git a/R/export.r b/R/export.r index 20d53ef0..ee03828b 100644 --- a/R/export.r +++ b/R/export.r @@ -1,216 +1,214 @@ - -############################# EXPORT TXT #################################### - - -#' Save grid in a text file (txt). -#' -#' `saveAsTxt` will save the grid as a `.txt` file -#' in format used by \pkg{OpenRepGrid}. This file format can also -#' easily be edited by hand (see [importTxt()] for a -#' description). -#' -#' @param x `repgrid` object. -#' @param file Filename to save the grid to. The name should have -#' the suffix `.txt`. -#' @return Invisibly returns the name of the file. -#' -#' @note -#' Structure of a txt file that can be read by [importTxt()]. -#' -#' `---------------- .txt file -----------------` -#' -#' `anything not contained within the tags will be discarded` -#' -#' \tabular{l}{ -#' `ELEMENTS` \cr -#' `element 1` \cr -#' `element 2` \cr -#' `element 3` \cr -#' `END ELEMENTS` \cr -#' \cr -#' `CONSTRUCTS` \cr -#' `left pole 1 : right pole 1` \cr -#' `left pole 2 : right pole 2` \cr -#' `left pole 3 : right pole 3` \cr -#' `left pole 4 : right pole 4` \cr -#' `END CONSTRUCTS` \cr -#' \cr -#' `RATINGS` \cr -#' `1 3 2` \cr -#' `4 1 1` \cr -#' `1 4 4` \cr -#' `3 1 1` \cr -#' `END RATINGS` \cr -#' \cr -#' `RANGE` \cr -#' `1 4` \cr -#' `END RANGE` \cr -#' } -#' `---------------- end of file ----------------` -#' -#' @export -#' @seealso [importTxt()] -#' @examples \dontrun{ -#' -#' x <- randomGrid() -#' saveAsTxt(x, "random.txt") -#' -#' } -#' -saveAsTxt <- function(x, file = NA) { - fileName <- file - enames <- elements(x) - cnames <- constructs(x) - scores <- getRatingLayer(x) - # write txt file - con <- file(fileName, "w") # open an output file connection - - cat("=========================\n", file = con) - cat("Data File for OpenRepGrid\n", file = con) - cat("=========================\n", file = con) - - # write element names - cat("\nELEMENTS\n", file = con) - for (ename in enames) - cat(ename, "\n", sep="", file=con) - cat("END ELEMENTS\n", file = con) - - # write construct names - cat("\nCONSTRUCTS\n", file = con) - cnames.string <- paste(cnames[,1], ":", cnames[, 2]) - for (cname in cnames.string) - cat(cname, "\n", sep="", file=con) - cat("END CONSTRUCTS\n", file = con) - - # write ratings to file - cat("\nRATINGS\n", file = con) - write.table(scores, file = con, sep = " ", - row.names = FALSE, col.names=FALSE) - cat("END RATINGS\n", file = con) - - # write scale range to file - cat("\nRANGE\n", file = con) - cat(x@scale$min, x@scale$max, "\n", file=con) - cat("END RANGE\n", file = con) - - close(con) - cat("grid succesfully written to file: ", unlist(fileName)) - - invisible(fileName) -} - - -### .TXT FILE FORMAT ### - -# everything not contained within the tags will be discarded -# -# ELEMENTS -# element 1 -# element 2 -# element 3 -# element 4 -# END ELEMENTS -# -# CONSTRUCTS -# left pole 1 : right pole 1 -# left pole 2 : right pole 2 -# left pole 3 : right pole 3 -# left pole 4 : right pole 4 -# END CONSTRUCTS -# -# RATINGS -# 1 3 NA 2 -# 4 1 3 NA -# 1 4 1 3 -# 3 1 1 6 -# END RATINGS -# -# RANGE -# 1 6 -# END RANGE - - -# exportTxt <- function(x, file=NULL) -# { -# file <- "test.txt" -# # redirect output to connection -# sink(file) -# -# # elements -# cat("\n") -# cat("ELEMENTS\n") -# for (name in getElementNames(g)) -# cat(name, "\n") -# cat("END ELEMENTS\n\n") -# -# # constructs -# cat("CONSTRUCTS\n") -# for (name in getConstructNames2(g, sep=" : ", trim=NA)) -# cat(name, "\n") -# cat("END CONSTRUCTS\n\n") -# -# # ratings -# cat("RATINGS\n") -# r <- getRatingLayer(g) -# for (i in 1:nrow(r)) -# cat(r[i, ], "\n") -# cat("END RATINGS\n\n") -# -# # range -# cat("RANGE\n") -# cat(getScale(g), "\n") -# cat("END RANGE\n\n") -# -# # reset output stream -# sink() -# } - - -############################# EXPORT EXCEL #################################### - - -#' Save grid in a Microsoft Excel file (.xlsx) -#' -#' `saveAsExcel` will save the grid as a Microsoft Excel file -#' (`.xlsx`). -#' -#' @param x A `repgrid` object. -#' @param file Filename to save the grid to. The name should have -#' the suffix `.xlsx`. -#' @param sheet Index of the sheet to write to. -#' @return Invisibly returns the name of the file. -#' @export -#' @seealso [importExcel()] -#' @examples \dontrun{ -#' -#' x <- randomGrid(options=0) -#' saveAsExcel(x, "grid.xlsx") -#' -#' } -#' -saveAsExcel <- function(x, file, sheet=1) -{ - # check for correct file extension - ext <- tools::file_ext(file) - if (ext != "xlsx") - stop("The file extension must be '.xlsx' but you have '.", ext, "'", call. = FALSE) - - # build matrix to write to Excel - enames <- elements(x) - cnames <- constructs(x) - scores <- ratings(x, names=FALSE) - mm <- getScale(x) # min, max - - part1 <- c(mm[1], enames, mm[2]) - part2 <- cbind(cnames$leftpole, scores, cnames$rightpole) - m <- rbind(part1, part2) - m <- unname(m) - - # write to disk - openxlsx::write.xlsx(m, file, colNames = FALSE, rowNames = FALSE, sheet=sheet) - - invisible(file) -} - - - +############################# EXPORT TXT #################################### + + +#' Save grid in a text file (txt). +#' +#' `saveAsTxt` will save the grid as a `.txt` file +#' in format used by \pkg{OpenRepGrid}. This file format can also +#' easily be edited by hand (see [importTxt()] for a +#' description). +#' +#' @param x `repgrid` object. +#' @param file Filename to save the grid to. The name should have +#' the suffix `.txt`. +#' @return Invisibly returns the name of the file. +#' +#' @note +#' Structure of a txt file that can be read by [importTxt()]. +#' +#' `---------------- .txt file -----------------` +#' +#' `anything not contained within the tags will be discarded` +#' +#' \tabular{l}{ +#' `ELEMENTS` \cr +#' `element 1` \cr +#' `element 2` \cr +#' `element 3` \cr +#' `END ELEMENTS` \cr +#' \cr +#' `CONSTRUCTS` \cr +#' `left pole 1 : right pole 1` \cr +#' `left pole 2 : right pole 2` \cr +#' `left pole 3 : right pole 3` \cr +#' `left pole 4 : right pole 4` \cr +#' `END CONSTRUCTS` \cr +#' \cr +#' `RATINGS` \cr +#' `1 3 2` \cr +#' `4 1 1` \cr +#' `1 4 4` \cr +#' `3 1 1` \cr +#' `END RATINGS` \cr +#' \cr +#' `RANGE` \cr +#' `1 4` \cr +#' `END RANGE` \cr +#' } +#' `---------------- end of file ----------------` +#' +#' @export +#' @seealso [importTxt()] +#' @examples \dontrun{ +#' +#' x <- randomGrid() +#' saveAsTxt(x, "random.txt") +#' } +#' +saveAsTxt <- function(x, file = NA) { + fileName <- file + enames <- elements(x) + cnames <- constructs(x) + scores <- getRatingLayer(x) + # write txt file + con <- file(fileName, "w") # open an output file connection + + cat("=========================\n", file = con) + cat("Data File for OpenRepGrid\n", file = con) + cat("=========================\n", file = con) + + # write element names + cat("\nELEMENTS\n", file = con) + for (ename in enames) { + cat(ename, "\n", sep = "", file = con) + } + cat("END ELEMENTS\n", file = con) + + # write construct names + cat("\nCONSTRUCTS\n", file = con) + cnames.string <- paste(cnames[, 1], ":", cnames[, 2]) + for (cname in cnames.string) { + cat(cname, "\n", sep = "", file = con) + } + cat("END CONSTRUCTS\n", file = con) + + # write ratings to file + cat("\nRATINGS\n", file = con) + write.table(scores, + file = con, sep = " ", + row.names = FALSE, col.names = FALSE + ) + cat("END RATINGS\n", file = con) + + # write scale range to file + cat("\nRANGE\n", file = con) + cat(x@scale$min, x@scale$max, "\n", file = con) + cat("END RANGE\n", file = con) + + close(con) + cat("grid succesfully written to file: ", unlist(fileName)) + + invisible(fileName) +} + + +### .TXT FILE FORMAT ### + +# everything not contained within the tags will be discarded +# +# ELEMENTS +# element 1 +# element 2 +# element 3 +# element 4 +# END ELEMENTS +# +# CONSTRUCTS +# left pole 1 : right pole 1 +# left pole 2 : right pole 2 +# left pole 3 : right pole 3 +# left pole 4 : right pole 4 +# END CONSTRUCTS +# +# RATINGS +# 1 3 NA 2 +# 4 1 3 NA +# 1 4 1 3 +# 3 1 1 6 +# END RATINGS +# +# RANGE +# 1 6 +# END RANGE + + +# exportTxt <- function(x, file=NULL) +# { +# file <- "test.txt" +# # redirect output to connection +# sink(file) +# +# # elements +# cat("\n") +# cat("ELEMENTS\n") +# for (name in getElementNames(g)) +# cat(name, "\n") +# cat("END ELEMENTS\n\n") +# +# # constructs +# cat("CONSTRUCTS\n") +# for (name in getConstructNames2(g, sep=" : ", trim=NA)) +# cat(name, "\n") +# cat("END CONSTRUCTS\n\n") +# +# # ratings +# cat("RATINGS\n") +# r <- getRatingLayer(g) +# for (i in 1:nrow(r)) +# cat(r[i, ], "\n") +# cat("END RATINGS\n\n") +# +# # range +# cat("RANGE\n") +# cat(getScale(g), "\n") +# cat("END RANGE\n\n") +# +# # reset output stream +# sink() +# } + + +############################# EXPORT EXCEL #################################### + + +#' Save grid in a Microsoft Excel file (.xlsx) +#' +#' `saveAsExcel` will save the grid as a Microsoft Excel file +#' (`.xlsx`). +#' +#' @param x A `repgrid` object. +#' @param file Filename to save the grid to. The name should have +#' the suffix `.xlsx`. +#' @param sheet Index of the sheet to write to. +#' @return Invisibly returns the name of the file. +#' @export +#' @seealso [importExcel()] +#' @examples \dontrun{ +#' +#' x <- randomGrid(options = 0) +#' saveAsExcel(x, "grid.xlsx") +#' } +#' +saveAsExcel <- function(x, file, sheet = 1) { + # check for correct file extension + ext <- tools::file_ext(file) + if (ext != "xlsx") { + stop("The file extension must be '.xlsx' but you have '.", ext, "'", call. = FALSE) + } + + # build matrix to write to Excel + enames <- elements(x) + cnames <- constructs(x) + scores <- ratings(x, names = FALSE) + mm <- getScale(x) # min, max + + part1 <- c(mm[1], enames, mm[2]) + part2 <- cbind(cnames$leftpole, scores, cnames$rightpole) + m <- rbind(part1, part2) + m <- unname(m) + + # write to disk + openxlsx::write.xlsx(m, file, colNames = FALSE, rowNames = FALSE, sheet = sheet) + + invisible(file) +} diff --git a/R/globals.R b/R/globals.R index de3e29a5..5d78471f 100644 --- a/R/globals.R +++ b/R/globals.R @@ -1,6 +1,7 @@ -# Avoid 'no visible binding for global variable' warnings in R CMD CHECK This code comes from a -# contributor. We might need to have a look to avoid these warnings all togther. This is a quick fix -# for now. -utils::globalVariables(c("Self", "Ideal", "Construct", "Difference", "id_c", "id_d", "Dilemmatic", - "Polarization", "name", "Classification")) - \ No newline at end of file +# Avoid 'no visible binding for global variable' warnings in R CMD CHECK This code comes from a +# contributor. We might need to have a look to avoid these warnings all togther. This is a quick fix +# for now. +utils::globalVariables(c( + "Self", "Ideal", "Construct", "Difference", "id_c", "id_d", "Dilemmatic", + "Polarization", "name", "Classification" +)) diff --git a/R/gmMain.r b/R/gmMain.r index 33accae4..ffd288d3 100644 --- a/R/gmMain.r +++ b/R/gmMain.r @@ -1,43 +1,43 @@ -#////////////////////////////////////////////////////////////////////////////// -# GRAPHICAL MODULES (gm) script collection -# graphical moduls is a collection of simple graphical templates +# ////////////////////////////////////////////////////////////////////////////// +# GRAPHICAL MODULES (gm) script collection +# graphical moduls is a collection of simple graphical templates # that can be used to construct complex custom graphics. # All functions from this collection start with the letters gm. -# Similar to the grid package when a grob is given as output -# the same functions name ends with Grob and has a corresponding -# cuntion that does not have grob at the end. e.g. gmFoo and gmFooGrob -# +# Similar to the grid package when a grob is given as output +# the same functions name ends with Grob and has a corresponding +# cuntion that does not have grob at the end. e.g. gmFoo and gmFooGrob +# # by Mark Heckmann 2009 -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # TODO: naming of function and corresponding grob function # package dependencies: -#require(grid) -#require(colorspace) +# require(grid) +# require(colorspace) -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// ###### FUNCTION DEFINITION ######## -# extract luminance value from hex color value. +# extract luminance value from hex color value. # done by conversion to rgb to lch space # luminance is returned # works vectorwise # default.na is value returned if hex contains NAs -gmGetHexLuminanceValues <- function(hex, default.na =NA) -{ - sapply(hex, function(x){ # check if strings are hex, that is if the start with a "#" - if(substr(x, 1, 1)!="#" & !is.na(x)) - stop("hex is not hexadecimal. getHexLuminanceValues() needs a hex color value!") - } ) - NAs <- is.na(hex) # hex2RGB needs hex values, NAs not accepted - hex[NAs] <- "#FFFFFF" # replace NAs by dummy hex value (white) - - lch <- as(hex2RGB(hex), "polarLUV") # convert hex to rgb to lch , thanks to A. Zeileis r-help 20100129 - lum <- as.vector(lch@coords[,"L"]) # return the luminance values only - lum[NAs] <- default.na - lum +gmGetHexLuminanceValues <- function(hex, default.na = NA) { + sapply(hex, function(x) { # check if strings are hex, that is if the start with a "#" + if (substr(x, 1, 1) != "#" & !is.na(x)) { + stop("hex is not hexadecimal. getHexLuminanceValues() needs a hex color value!") + } + }) + NAs <- is.na(hex) # hex2RGB needs hex values, NAs not accepted + hex[NAs] <- "#FFFFFF" # replace NAs by dummy hex value (white) + + lch <- as(hex2RGB(hex), "polarLUV") # convert hex to rgb to lch , thanks to A. Zeileis r-help 20100129 + lum <- as.vector(lch@coords[, "L"]) # return the luminance values only + lum[NAs] <- default.na + lum } ## NOT RUN @@ -45,17 +45,16 @@ gmGetHexLuminanceValues <- function(hex, default.na =NA) ###### FUNCTION DEFINITION ######## -# select a color from supplied vector corresponding to the +# select a color from supplied vector corresponding to the # luminance value of given hex colors and given breaks -# if hex contains NAs a default hex value can be passed and +# if hex contains NAs a default hex value can be passed and # works vectorwise # default.na is value returned if hex contains NAs -gmSelectTextColorByLuminance <- function(hex, breaks=c(-1,50,101), breakColors=c("white", "black"), default.na=NA) -{ - luminanceVec <- gmGetHexLuminanceValues(hex) # get luminance values from hex color - indices <- as.integer(cut(luminanceVec, breaks=breaks)) # cut by breaks and get indices - breakColors[indices] # return color by index +gmSelectTextColorByLuminance <- function(hex, breaks = c(-1, 50, 101), breakColors = c("white", "black"), default.na = NA) { + luminanceVec <- gmGetHexLuminanceValues(hex) # get luminance values from hex color + indices <- as.integer(cut(luminanceVec, breaks = breaks)) # cut by breaks and get indices + breakColors[indices] # return color by index } ## NOT RUN @@ -63,154 +62,174 @@ gmSelectTextColorByLuminance <- function(hex, breaks=c(-1,50,101), breakColors=c ### SHOW EXAMPLE ### ## plot with random background and corresponding textcolor -#library(RColorBrewer) -#bgColors <- c(brewer.pal(8,"Purples"), brewer.pal(8,"YlOrRd")) -#textColors <- gmSelectTextColorByLuminance(bgColors) +# library(RColorBrewer) +# bgColors <- c(brewer.pal(8,"Purples"), brewer.pal(8,"YlOrRd")) +# textColors <- gmSelectTextColorByLuminance(bgColors) -#pushViewport(viewport(layout=grid.layout(4, 4, respect=TRUE))) -# for(i in 1:4){ -# for(j in 1:4){ -# grid.rect(gp=gpar(col="white", fill=bgColors[4*(i-1) + j]), vp=viewport(layout.pos.col=j, layout.pos.row=i)) -# grid.text(paste("Zelle (", i, ",", j, ")", sep=""), gp=gpar(col=textColors[4*(i-1) + j]), vp=viewport(layout.pos.col=j, layout.pos.row=i)) -# } -# } -#popViewport() +# pushViewport(viewport(layout=grid.layout(4, 4, respect=TRUE))) +# for(i in 1:4){ +# for(j in 1:4){ +# grid.rect(gp=gpar(col="white", fill=bgColors[4*(i-1) + j]), vp=viewport(layout.pos.col=j, layout.pos.row=i)) +# grid.text(paste("Zelle (", i, ",", j, ")", sep=""), gp=gpar(col=textColors[4*(i-1) + j]), vp=viewport(layout.pos.col=j, layout.pos.row=i)) +# } +# } +# popViewport() -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # like a gmTextBox -# like Murrels example that is rezisable but also viewport +# like Murrels example that is rezisable but also viewport # rotation enabled allowed -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # gmTextBox fill a viewport with color, and text or two texts # # evtl mit gpar Objekten?? -# wenn zwei Texte übergeben werden, so werden diese, je nachdem, ob horiz=TRUE oder FALSE ist neben +# wenn zwei Texte übergeben werden, so werden diese, je nachdem, ob horiz=TRUE oder FALSE ist neben # oder untereinander dargestellt. # TODO: ggf. das plotten von borderlines integrieren? -# Probleme mit den Rändern. - -gmTextBox <- function(text=c("text 1", "text 2"), textCol = c("black", "black"), - bgCol = c(grey(.9), grey(.9)), vp=viewport(), textsize= c(.8, .8), - fontface=c("bold", "plain"), horiz=FALSE, vAdjust = c(.4, .65)) -{ - #vp=viewport() - #text=c("text 1", "text 2") - #textCol = c("black", "black") - #bgCol = "grey" - #horiz=FALSE - #borderCol <- c("black", "black", "black","black") - #twoTexts <- TRUE - ### - - if(length(text) == 2 ) {twoTexts <- TRUE} else {twoTexts <- FALSE} # two text bodies? - gpText_1 <- gpar(col=textCol[1], cex=textsize[1], fontface=fontface[1]) # make gpar objects - gpText_2 <- gpar(col=textCol[2], cex=textsize[2], fontface=fontface[2]) # - gpFill_1 <- gpar(fill=bgCol[1], col=bgCol[1])#, col=NA) # no border - gpFill_2 <- gpar(fill=bgCol[2], col= bgCol[2])#, col=NA) # no border - - # three options: 1 text, 2 texts vertical, 2 texts horizontal - - if(!twoTexts){ # just one text body - pushViewport(vp) - grid.rect(gp=gpFill_1) - grid.text(text[1], gp=gpText_1) - popViewport() - } - - # TODO: dieser Ansatz ist noch nicht perfekt. Speziell, da ich verschiedene fontfaces für - # die obere und untere Zelle haben möchte müssen zwei textGrobs gebaut werden. Hier muss - # noch ein wenig Arbeit geleistet werden, um deren Größe zu messen unds ie nebeneinander - # sauber zu platzieren. Vlt. in der nächsten Version. - if(twoTexts){ # two text bodies - pushViewport(vp) # outer viewport - if(horiz){ nRow <- 1; nCol <- 2; yOffset=.5 } else {nRow <- 2; nCol <- 1; yOffset=vAdjust[1]} # define layout with respect to orientation (horiz T/F) - pushViewport(viewport(layout=grid.layout(nRow,nCol))) # split viewport horizontally or vertically (horiz T/F) - posRow <- 1; posCol <- 1 # define row and column position of first viewport - pushViewport(viewport(layout.pos.row=posRow, layout.pos.col=posCol)) # push upper viewport - grid.rect(gp=gpFill_1) - grid.text(y=yOffset, text[1], gp=gpText_1, just=c("center", "center")) - popViewport() - if(horiz){ posRow <- 1; posCol <- 2; yOffset=.5} else { posRow <- 2; posCol <- 1; yOffset=vAdjust[2]} # define row and column position of second viewport - pushViewport(viewport(layout.pos.row=posRow, layout.pos.col=posCol)) # push lower viewport - grid.rect(gp=gpFill_2) - grid.text(y=yOffset, text[2], gp=gpText_2, just=c("center", "center")) - popViewport() - popViewport() - grid.rect(gp=gpar(col="white", lwd=2)) # border around whole vp - popViewport() - } +# Probleme mit den Rändern. + +gmTextBox <- function(text = c("text 1", "text 2"), textCol = c("black", "black"), + bgCol = c(grey(.9), grey(.9)), vp = viewport(), textsize = c(.8, .8), + fontface = c("bold", "plain"), horiz = FALSE, vAdjust = c(.4, .65)) { + # vp=viewport() + # text=c("text 1", "text 2") + # textCol = c("black", "black") + # bgCol = "grey" + # horiz=FALSE + # borderCol <- c("black", "black", "black","black") + # twoTexts <- TRUE + ### + + if (length(text) == 2) { + twoTexts <- TRUE + } else { + twoTexts <- FALSE + } # two text bodies? + gpText_1 <- gpar(col = textCol[1], cex = textsize[1], fontface = fontface[1]) # make gpar objects + gpText_2 <- gpar(col = textCol[2], cex = textsize[2], fontface = fontface[2]) # + gpFill_1 <- gpar(fill = bgCol[1], col = bgCol[1]) # , col=NA) # no border + gpFill_2 <- gpar(fill = bgCol[2], col = bgCol[2]) # , col=NA) # no border + + # three options: 1 text, 2 texts vertical, 2 texts horizontal + + if (!twoTexts) { # just one text body + pushViewport(vp) + grid.rect(gp = gpFill_1) + grid.text(text[1], gp = gpText_1) + popViewport() + } + + # TODO: dieser Ansatz ist noch nicht perfekt. Speziell, da ich verschiedene fontfaces für + # die obere und untere Zelle haben möchte müssen zwei textGrobs gebaut werden. Hier muss + # noch ein wenig Arbeit geleistet werden, um deren Größe zu messen unds ie nebeneinander + # sauber zu platzieren. Vlt. in der nächsten Version. + if (twoTexts) { # two text bodies + pushViewport(vp) # outer viewport + if (horiz) { + nRow <- 1 + nCol <- 2 + yOffset <- .5 + } else { + nRow <- 2 + nCol <- 1 + yOffset <- vAdjust[1] + } # define layout with respect to orientation (horiz T/F) + pushViewport(viewport(layout = grid.layout(nRow, nCol))) # split viewport horizontally or vertically (horiz T/F) + posRow <- 1 + posCol <- 1 # define row and column position of first viewport + pushViewport(viewport(layout.pos.row = posRow, layout.pos.col = posCol)) # push upper viewport + grid.rect(gp = gpFill_1) + grid.text(y = yOffset, text[1], gp = gpText_1, just = c("center", "center")) + popViewport() + if (horiz) { + posRow <- 1 + posCol <- 2 + yOffset <- .5 + } else { + posRow <- 2 + posCol <- 1 + yOffset <- vAdjust[2] + } # define row and column position of second viewport + pushViewport(viewport(layout.pos.row = posRow, layout.pos.col = posCol)) # push lower viewport + grid.rect(gp = gpFill_2) + grid.text(y = yOffset, text[2], gp = gpText_2, just = c("center", "center")) + popViewport() + popViewport() + grid.rect(gp = gpar(col = "white", lwd = 2)) # border around whole vp + popViewport() + } } ### NOT RUN ### -#gmTextBox() -#gmTextBox(c(12,"(14 %)")) -#gmTextBox(c(12)) +# gmTextBox() +# gmTextBox(c(12,"(14 %)")) +# gmTextBox(c(12)) ## make a grid of gmTextBoxes -#pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE))) -# for(i in 1:4){ -# for(j in 1:4){ -# gmTextBox(vp=viewport(layout.pos.row=i, layout.pos.col=j)) -# } -# } -#popViewport() +# pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE))) +# for(i in 1:4){ +# for(j in 1:4){ +# gmTextBox(vp=viewport(layout.pos.row=i, layout.pos.col=j)) +# } +# } +# popViewport() ## use data from data frame -#script <- matrix(sample(1:100, 16), ncol=4) -#subscript <- matrix(paste("(", sample(1:100, 16), "%)", sep=""), ncol=4) -#nCol <- ncol(script); nRow <- nrow(script) -#pushViewport(viewport(layout=grid.layout(nRow, nCol, respect=FALSE))) -# for(i in 1:nRow){ -# for(j in 1:nCol){ -# gmTextBox(c(script[i,j], subscript[i,j]), horiz=FALSE, vp=viewport(layout.pos.row=i, layout.pos.col=j)) -# } -# } -#popViewport() +# script <- matrix(sample(1:100, 16), ncol=4) +# subscript <- matrix(paste("(", sample(1:100, 16), "%)", sep=""), ncol=4) +# nCol <- ncol(script); nRow <- nrow(script) +# pushViewport(viewport(layout=grid.layout(nRow, nCol, respect=FALSE))) +# for(i in 1:nRow){ +# for(j in 1:nCol){ +# gmTextBox(c(script[i,j], subscript[i,j]), horiz=FALSE, vp=viewport(layout.pos.row=i, layout.pos.col=j)) +# } +# } +# popViewport() ## plot with random background colors and corresponding textcolor overlay -#library(RColorBrewer) - -#bgColors <- brewer.pal(8,"YlOrRd") -#script <- matrix(sample(1:100, 16), ncol=4) -#subscript <- matrix(paste("(", sample(1:100, 16), "%)", sep=""), ncol=4) -#bgColorsScript <- matrix(sample(bgColors, 16, rep=T), ncol=4) -#textColorsScript <- matrix(gmSelectTextColorByLuminance(bgColorsScript), ncol=4) # benutzt gmSelectTextColorByLuminance - -#nCol <- ncol(script); nRow <- nrow(script) -#pushViewport(viewport(layout=grid.layout(nRow, nCol, respect=TRUE))) -# for(i in 1:nRow){ -# for(j in 1:nCol){ -# gmTextBox(text=c(script[i,j], subscript[i,j]), textCol=c(textColorsScript[i,j], textColorsScript[i,j]), -# bgCol=c(bgColorsScript[i,j], bgColorsScript[i,j]), vp=viewport(layout.pos.row=i, layout.pos.col=j)) -# } -# } -#popViewport() +# library(RColorBrewer) + +# bgColors <- brewer.pal(8,"YlOrRd") +# script <- matrix(sample(1:100, 16), ncol=4) +# subscript <- matrix(paste("(", sample(1:100, 16), "%)", sep=""), ncol=4) +# bgColorsScript <- matrix(sample(bgColors, 16, rep=T), ncol=4) +# textColorsScript <- matrix(gmSelectTextColorByLuminance(bgColorsScript), ncol=4) # benutzt gmSelectTextColorByLuminance + +# nCol <- ncol(script); nRow <- nrow(script) +# pushViewport(viewport(layout=grid.layout(nRow, nCol, respect=TRUE))) +# for(i in 1:nRow){ +# for(j in 1:nCol){ +# gmTextBox(text=c(script[i,j], subscript[i,j]), textCol=c(textColorsScript[i,j], textColorsScript[i,j]), +# bgCol=c(bgColorsScript[i,j], bgColorsScript[i,j]), vp=viewport(layout.pos.row=i, layout.pos.col=j)) +# } +# } +# popViewport() ## uses gmRandomColor -#nRow <- 5; nCol <- 5 -#script <- matrix(sample(1:100, nRow*nCol), ncol=nCol) -#subscript <- matrix(paste("(", sample(1:100, nRow*nCol), "%)", sep=""), ncol=nCol) -#pushViewport(viewport(layout=grid.layout(nRow, nCol, respect=TRUE))) -# for(i in 1:nRow){ -# for(j in 1:nCol){ -# randColor <- gmRandomColor() -# gmTextBox(text=c(script[i,j], subscript[i,j]), textCol=rep(gmSelectTextColorByLuminance(randColor),2), -# bgCol=rep(randColor, 2), vp=viewport(layout.pos.row=i, layout.pos.col=j)) -# } -# } -#popViewport() - - -#////////////////////////////////////////////////////////////////////////////// +# nRow <- 5; nCol <- 5 +# script <- matrix(sample(1:100, nRow*nCol), ncol=nCol) +# subscript <- matrix(paste("(", sample(1:100, nRow*nCol), "%)", sep=""), ncol=nCol) +# pushViewport(viewport(layout=grid.layout(nRow, nCol, respect=TRUE))) +# for(i in 1:nRow){ +# for(j in 1:nCol){ +# randColor <- gmRandomColor() +# gmTextBox(text=c(script[i,j], subscript[i,j]), textCol=rep(gmSelectTextColorByLuminance(randColor),2), +# bgCol=rep(randColor, 2), vp=viewport(layout.pos.row=i, layout.pos.col=j)) +# } +# } +# popViewport() + + +# ////////////////////////////////////////////////////////////////////////////// # gmSplitTextGrob # text grob that automatically does line breaks in text, allows resizing @@ -221,245 +240,248 @@ gmTextBox <- function(text=c("text 1", "text 2"), textCol = c("black", "black"), # - no vectorized form available yet # adopted from Murrell(2008) R Graphics, p... -gmSplitString <- function(text, horiz=TRUE, splitWidth=unit(.98, "npc")) # function to split grobtext -{ - #require(grid) - if(is.expression(text)){ # Expressions können nicht weiter verarbeitet werden - return(text) - #break - } - if(is.null(text)) text <- "" - if(length(text) ==1 & is.na(text)) text <- "" - if(is.character(text) & length(text)==0) text <- "" - if(text==""){ - return(paste(text)) - #break - } - strings <- strsplit(as.character(text), " ")[[1]] - if(length(strings)==1){ - return(paste(strings)) - #break - } - newstring <- strings[1] - linewidth <- stringWidth(newstring) - gapwidth <- stringWidth(" ") - - if(!horiz){ - availwidth <- convertHeight(splitWidth, "inches", valueOnly=TRUE) - }else{ - availwidth <- convertWidth(splitWidth, "inches", valueOnly=TRUE) - } - #print(availwidth); - for (i in 2:length(strings)){ - width <- stringWidth(strings[i]) - if (convertWidth(linewidth + gapwidth + width, - "inches", valueOnly=TRUE) < availwidth){ - sep <- " " - linewidth <- linewidth + gapwidth + width - } else { - sep <- "\n" - linewidth <- width - } - newstring <- paste(newstring, strings[i], sep=sep) - } - newstring +gmSplitString <- function(text, horiz = TRUE, splitWidth = unit(.98, "npc")) # function to split grobtext +{ + # require(grid) + if (is.expression(text)) { # Expressions können nicht weiter verarbeitet werden + return(text) + # break + } + if (is.null(text)) text <- "" + if (length(text) == 1 & is.na(text)) text <- "" + if (is.character(text) & length(text) == 0) text <- "" + if (text == "") { + return(paste(text)) + # break + } + strings <- strsplit(as.character(text), " ")[[1]] + if (length(strings) == 1) { + return(paste(strings)) + # break + } + newstring <- strings[1] + linewidth <- stringWidth(newstring) + gapwidth <- stringWidth(" ") + + if (!horiz) { + availwidth <- convertHeight(splitWidth, "inches", valueOnly = TRUE) + } else { + availwidth <- convertWidth(splitWidth, "inches", valueOnly = TRUE) + } + # print(availwidth); + for (i in 2:length(strings)) { + width <- stringWidth(strings[i]) + if (convertWidth(linewidth + gapwidth + width, + "inches", + valueOnly = TRUE + ) < availwidth) { + sep <- " " + linewidth <- linewidth + gapwidth + width + } else { + sep <- "\n" + linewidth <- width + } + newstring <- paste(newstring, strings[i], sep = sep) + } + newstring } # make text grob -gmSplitTextGrob <- function(text, x=unit(0.5, "npc"), y=unit(0.5, "npc"), just=c("center", "center"), gp=gpar(), horiz=TRUE, splitWidth=unit(.98, "npc"), ...) -{ - if (!is.unit(splitWidth)) splitWidth <- unit(splitWidth, "npc") +gmSplitTextGrob <- function(text, x = unit(0.5, "npc"), y = unit(0.5, "npc"), just = c("center", "center"), gp = gpar(), horiz = TRUE, splitWidth = unit(.98, "npc"), ...) { + if (!is.unit(splitWidth)) splitWidth <- unit(splitWidth, "npc") - if(!horiz) rot <- 90 else rot <- 0 - #print(horiz); print(rot); - grob(text=text, cl="gmSplitTextGrob", x=x, y=y, just=just, rot = rot, horiz=horiz, gp=gp, splitWidth=splitWidth, ...) + if (!horiz) rot <- 90 else rot <- 0 + # print(horiz); print(rot); + grob(text = text, cl = "gmSplitTextGrob", x = x, y = y, just = just, rot = rot, horiz = horiz, gp = gp, splitWidth = splitWidth, ...) } # variation to explore -drawDetails.gmSplitTextGrob <- function(x, recording) # drawdetails method is called when resizing window -{ - #str(x); - if(!x$horiz) { - grid.text(label=gmSplitString(x$text, horiz=x$horiz, splitWidth=x$splitWidth), - rot=x$rot, just=x$just, x=x$x, y=x$y, gp=x$gp) - } else { - grid.text(label=gmSplitString(x$text, horiz=x$horiz, splitWidth=x$splitWidth), - rot=x$rot, just=x$just, x=x$x, y=x$y, gp=x$gp,) - } +drawDetails.gmSplitTextGrob <- function(x, recording) # drawdetails method is called when resizing window +{ + # str(x); + if (!x$horiz) { + grid.text( + label = gmSplitString(x$text, horiz = x$horiz, splitWidth = x$splitWidth), + rot = x$rot, just = x$just, x = x$x, y = x$y, gp = x$gp + ) + } else { + grid.text( + label = gmSplitString(x$text, horiz = x$horiz, splitWidth = x$splitWidth), + rot = x$rot, just = x$just, x = x$x, y = x$y, gp = x$gp, + ) + } } -# printing wrapper for gmSplitTextGrob -gmSplitTextBox <- function(text, x=unit(0.5, "npc"), y=unit(0.5, "npc"), just=c("center", "center"), gp=gpar(), horiz=TRUE, splitWidth=unit(.98, "npc"), ...) -{ - tg <- gmSplitTextGrob(text, x=x, y=y, just=just, gp=gp, horiz=horiz, splitWidth=splitWidth, ...) # gmSplitTextGrob - grid.draw(tg) # print gmSplitTextGrob -} +# printing wrapper for gmSplitTextGrob +gmSplitTextBox <- function(text, x = unit(0.5, "npc"), y = unit(0.5, "npc"), just = c("center", "center"), gp = gpar(), horiz = TRUE, splitWidth = unit(.98, "npc"), ...) { + tg <- gmSplitTextGrob(text, x = x, y = y, just = just, gp = gp, horiz = horiz, splitWidth = splitWidth, ...) # gmSplitTextGrob + grid.draw(tg) # print gmSplitTextGrob +} ### NOT RUN -#text <- "some random longer text that might be the label of an item" -#grid.draw(gmSplitTextGrob(text, horiz=T, just=c("center", "center"))) -#grid.draw(gmSplitTextGrob(text, horiz=T, splitWidth=.9, x=0.05, y=.5, just=c("left", "center"), gp=gpar(col="darkgrey"))) -#gmSplitTextBox(text, horiz=T, splitWidth=.9, x=0.05, y=.5, just=c("left", "center"), gp=gpar(col="darkgrey", lineheight=.8)) +# text <- "some random longer text that might be the label of an item" +# grid.draw(gmSplitTextGrob(text, horiz=T, just=c("center", "center"))) +# grid.draw(gmSplitTextGrob(text, horiz=T, splitWidth=.9, x=0.05, y=.5, just=c("left", "center"), gp=gpar(col="darkgrey"))) +# gmSplitTextBox(text, horiz=T, splitWidth=.9, x=0.05, y=.5, just=c("left", "center"), gp=gpar(col="darkgrey", lineheight=.8)) -#gmSplitTextBox(text, h=F) +# gmSplitTextBox(text, h=F) -#splitText <- gmSplitTextGrob(text, horiz=F, class="gmSplitTextGrob", gp=gpar(fontsize=12, lineheight=.9)) -#grid.draw(splitText) +# splitText <- gmSplitTextGrob(text, horiz=F, class="gmSplitTextGrob", gp=gpar(fontsize=12, lineheight=.9)) +# grid.draw(splitText) ## matrix of text with random orientation -#grid.newpage() -#text <- "some random longer text that might be the label of an item" -#textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4) -#pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE))) -# for(i in 1:4){ -# for(j in 1:4){ -# grid.draw(gmSplitTextGrob(text, horiz=textOrientation[i,j], -# vp=viewport(layout.pos.row=i, layout.pos.col=j), -# gp=gpar(fontsize=12, lineheight=.9))) -# grid.rect(vp=viewport(layout.pos.row=i, layout.pos.col=j)) -# } -# } -#popViewport() +# grid.newpage() +# text <- "some random longer text that might be the label of an item" +# textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4) +# pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE))) +# for(i in 1:4){ +# for(j in 1:4){ +# grid.draw(gmSplitTextGrob(text, horiz=textOrientation[i,j], +# vp=viewport(layout.pos.row=i, layout.pos.col=j), +# gp=gpar(fontsize=12, lineheight=.9))) +# grid.rect(vp=viewport(layout.pos.row=i, layout.pos.col=j)) +# } +# } +# popViewport() ## matrix of text with random orientation and random fore- and background color -#grid.newpage() -#text <- "some random longer text that might be the label of an item" -#textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4) -#pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE))) -# for(i in 1:4){ -# for(j in 1:4){ -# randColor <- gmRandomColor() -# grid.rect(vp=viewport(layout.pos.row=i, layout.pos.col=j), -# gp=gpar(fill=randColor, col="lightgrey"))) -# gmSplitTextBox(text, splitWidth=.9, horiz=textOrientation[i,j], vp=viewport(layout.pos.row=i, layout.pos.col=j), -# gp=gpar(fontsize=12, lineheight=.9, col=gmSelectTextColorByLuminance(randColor))) -# } -# } -#popViewport() - - -#////////////////////////////////////////////////////////////////////////////// +# grid.newpage() +# text <- "some random longer text that might be the label of an item" +# textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4) +# pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE))) +# for(i in 1:4){ +# for(j in 1:4){ +# randColor <- gmRandomColor() +# grid.rect(vp=viewport(layout.pos.row=i, layout.pos.col=j), +# gp=gpar(fill=randColor, col="lightgrey"))) +# gmSplitTextBox(text, splitWidth=.9, horiz=textOrientation[i,j], vp=viewport(layout.pos.row=i, layout.pos.col=j), +# gp=gpar(fontsize=12, lineheight=.9, col=gmSelectTextColorByLuminance(randColor))) +# } +# } +# popViewport() + + +# ////////////////////////////////////////////////////////////////////////////// # gmMakeVpBorders # uses the current vp and adds border lines at specified places # is useful for the construction of tables etc. and an alternative # to do this afterwards by whole lines. # be careful with the visually adequate order of the sides as they are printed in the order given by side -# TODO: - recycle vector in lwd etc.? Evtl. kann ein NA stattdessen lieber +# TODO: - recycle vector in lwd etc.? Evtl. kann ein NA stattdessen lieber # dazu genutzt werden, dass die Linie nicht gezeichnet wird. # - evtl. noch nicht ganz perfekt in bezug auf das clipping, da dies nicht # als Funtkionsargument implementiert ist -gmMakeVpBorders <- function(side, col, lwd, ...) -{ - #col <- gmRandomColor(4) - #side <- 1:4 - #lwd <- 50:54 - for(i in side){ - if(i==1 | i=="bottom") grid.lines(x=c(0,1), y=c(0,0), gp=gpar(lwd=lwd[side %in% i], col=col[side %in% i], lineend="square"), ...) - if(i==2 | i=="left") grid.lines(x=c(0,0), y=c(0,1), gp=gpar(lwd=lwd[side %in% i], col=col[side %in% i], lineend="square"), ...) - if(i==3 | i=="top") grid.lines(x=c(0,1), y=c(1,1), gp=gpar(lwd=lwd[side %in% i], col=col[side %in% i], lineend="square"), ...) - if(i==4 | i=="right") grid.lines(x=c(1,1), y=c(0,1), gp=gpar(lwd=lwd[side %in% i], col=col[side %in% i], lineend="square"), ...) - } +gmMakeVpBorders <- function(side, col, lwd, ...) { + # col <- gmRandomColor(4) + # side <- 1:4 + # lwd <- 50:54 + for (i in side) { + if (i == 1 | i == "bottom") grid.lines(x = c(0, 1), y = c(0, 0), gp = gpar(lwd = lwd[side %in% i], col = col[side %in% i], lineend = "square"), ...) + if (i == 2 | i == "left") grid.lines(x = c(0, 0), y = c(0, 1), gp = gpar(lwd = lwd[side %in% i], col = col[side %in% i], lineend = "square"), ...) + if (i == 3 | i == "top") grid.lines(x = c(0, 1), y = c(1, 1), gp = gpar(lwd = lwd[side %in% i], col = col[side %in% i], lineend = "square"), ...) + if (i == 4 | i == "right") grid.lines(x = c(1, 1), y = c(0, 1), gp = gpar(lwd = lwd[side %in% i], col = col[side %in% i], lineend = "square"), ...) + } } -#gmSplitTextBox("Some long text is written here", splitWidth=.9) -#gmMakeVpBorders(1:4, gmRandomColor(4), lwd=rep(30,4)) +# gmSplitTextBox("Some long text is written here", splitWidth=.9) +# gmMakeVpBorders(1:4, gmRandomColor(4), lwd=rep(30,4)) ## matrix of text with random orientation and random fore- and background color -#grid.newpage() -#text <- "some random longer text that might be the label of an item" -#textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4) -#pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE))) -# for(i in 2:3){ -# for(j in 2:3){ -# tmpVp <- viewport(layout.pos.row=i, layout.pos.col=j) -# grid.rect(gp=gpar(fill=gmRandomColor()), vp=tmpVp) -# gmSplitTextBox(text, splitWidth=.9, horiz=textOrientation[i,j], vp=tmpVp) -# gmMakeVpBorders(1:4, rep("grey", 4), lwd=rep(10,4), vp=tmpVp) -# } -# } -#popViewport() +# grid.newpage() +# text <- "some random longer text that might be the label of an item" +# textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4) +# pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE))) +# for(i in 2:3){ +# for(j in 2:3){ +# tmpVp <- viewport(layout.pos.row=i, layout.pos.col=j) +# grid.rect(gp=gpar(fill=gmRandomColor()), vp=tmpVp) +# gmSplitTextBox(text, splitWidth=.9, horiz=textOrientation[i,j], vp=tmpVp) +# gmMakeVpBorders(1:4, rep("grey", 4), lwd=rep(10,4), vp=tmpVp) +# } +# } +# popViewport() ## booktab like look -#grid.newpage() -#text <- "some random longer text that might be the label of an item" -#textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4) -#pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE))) -# for(i in 1:4){ -# for(j in 2:3){ -# tmpVp <- viewport(layout.pos.row=i, layout.pos.col=j, clip=T) # im Moment noch clipping bei vp definition. Lieber direkt in Funktion -# grid.rect(gp=gpar(fill=gmRandomColor(v=.8), col=NA), vp=tmpVp) -# gmSplitTextBox(text, splitWidth=.9, horiz=textOrientation[i,j], vp=tmpVp) -# gmMakeVpBorders(1:4, rep("black", 4), lwd=c(4,NA, 4, NA), vp=tmpVp) -# } -# } -#popViewport() +# grid.newpage() +# text <- "some random longer text that might be the label of an item" +# textOrientation <- matrix(sample(c(T,F), 16, rep=TRUE), ncol=4) +# pushViewport(viewport(layout=grid.layout(4, 4, respect=FALSE))) +# for(i in 1:4){ +# for(j in 2:3){ +# tmpVp <- viewport(layout.pos.row=i, layout.pos.col=j, clip=T) # im Moment noch clipping bei vp definition. Lieber direkt in Funktion +# grid.rect(gp=gpar(fill=gmRandomColor(v=.8), col=NA), vp=tmpVp) +# gmSplitTextBox(text, splitWidth=.9, horiz=textOrientation[i,j], vp=tmpVp) +# gmMakeVpBorders(1:4, rep("black", 4), lwd=c(4,NA, 4, NA), vp=tmpVp) +# } +# } +# popViewport() -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// -# gmBulletPointsBox +# gmBulletPointsBox # A function that prints a list of text elements as bullet points # Bullets can be chosen any pch, numbers, letters or any other vector. -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # gmProfileLines # ask Hadley first if he already implicitly has it... -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// -# gmRandomColor +# gmRandomColor # small convenience wrapper that returns a vector of random colors as hex # unsing HSV scheme (hue, saturation, value) # (requires RColorBrewer package). # hue (1-360), saturation 0-1 and value 0-1 can be fixed or restricted to a range # shuffle = shuffle the outoput vector, so patterns are destroyed -gmRandomColor <- function(n=1, h=runif(n)*360, s=runif(n), v=runif(n), shuffle=TRUE, plot=FALSE ) -{ - #require(colorspace) - #hexColorVec <- hex(HSV(runif(n), runif(n), runif(n))) - hexColorVec <- hex(HSV(h, s, v)) - if(shuffle) hexColorVec <- hexColorVec[sample(seq_along(hexColorVec), length(hexColorVec))] - if(plot){ - pal <- function(col, border = "light gray", ...) - { - n <- length(col) - plot(0, 0, type="n", xlim = c(0, 1), ylim = c(0, 1), - axes = FALSE, xlab = "", ylab = "", ...) - rect(0:(n-1)/n, 0, 1:n/n, 1, col = col, border = border) - } - pal(hexColorVec) - } - return(hexColorVec) +gmRandomColor <- function(n = 1, h = runif(n) * 360, s = runif(n), v = runif(n), shuffle = TRUE, plot = FALSE) { + # require(colorspace) + # hexColorVec <- hex(HSV(runif(n), runif(n), runif(n))) + hexColorVec <- hex(HSV(h, s, v)) + if (shuffle) hexColorVec <- hexColorVec[sample(seq_along(hexColorVec), length(hexColorVec))] + if (plot) { + pal <- function(col, border = "light gray", ...) { + n <- length(col) + plot(0, 0, + type = "n", xlim = c(0, 1), ylim = c(0, 1), + axes = FALSE, xlab = "", ylab = "", ... + ) + rect(0:(n - 1) / n, 0, 1:n / n, 1, col = col, border = border) + } + pal(hexColorVec) + } + return(hexColorVec) } ### NOT RUN -# gmRandomColor() +# gmRandomColor() # gmRandomColor(20, plot=T) # gmRandomColor(30, h=100:200, v=3:10/10, p=T, shuffle=F) # gmRandomColor(30, h=100:200, v=3:10/10, p=T) -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # gmArrowIndicator -# an arrow of given size, angle, filling and background color which can be +# an arrow of given size, angle, filling and background color which can be # used to visuallize changes or rates. # angle # initAngle @@ -469,63 +491,70 @@ gmRandomColor <- function(n=1, h=runif(n)*360, s=runif(n), v=runif(n), shuffle=T # background ## deprecated due to grob version below -#gmArrowIndicator <- function(angle=0, col="black", size=5, circle=FALSE, ...) -#{ -# #gp <- modifyList(gpar(fill="black", col=NA, lwd=1, lineend ="square", # set default gpar and overwrite if provided -# # linejoin ="mitre", linemitre=1), gp) +# gmArrowIndicator <- function(angle=0, col="black", size=5, circle=FALSE, ...) +# { +# #gp <- modifyList(gpar(fill="black", col=NA, lwd=1, lineend ="square", # set default gpar and overwrite if provided +# # linejoin ="mitre", linemitre=1), gp) # -# if(hasArg(vp)) vp <- list(...)$vp else vp <- viewport() # if vp is passed use it else create empty viewport -# -# pushViewport(vp) -# pushViewport(viewport(angle=angle)) -# if(circle) grid.circle(x=0.5, y=0.5, r=unit(size+2,"mm"), gp=gpar(fill="lightgrey", col=NA)) -# -# arrow <- arrow(angle = 35, length = unit(size, "mm"), type = "closed") # make arrow object to be passed to grid.lines -# grid.lines( x = unit(c(.5, .5), "npc") + unit(c(0,size), "mm"), -# y = unit(c(.5, .5), "npc"), -# arrow = arrow, -# gp=gpar(fill=col, lwd=1, col=NA, lineend ="square", -# linejoin ="mitre", linemitre=1)) -# grid.lines( x = unit(c(.5, .5), "npc") + unit(c(-size/3,0), "mm"), -# y = unit(c(.5, .5), "npc"), -# gp= gpar(col=col, lwd=2*size, lineend ="square", linejoin ="mitre")) -# popViewport() -# popViewport() -#} - - - -gmArrowIndicatorGrob <- function(angle=0, col="black", size=5, circle=FALSE, initangle=0, ...) -{ - #gp <- modifyList(gpar(fill="black", col=NA, lwd=1, lineend ="square", # set default gpar and overwrite if provided - # linejoin ="mitre", linemitre=1), gp) - vp <- viewport(angle=angle + initangle) # created rotated viewport for arrow direction - if(hasArg(vp)) vp <- vpStack(list(...)$vp, vp) # if vp is passed use it and stack the two viewports - if(circle) - circleBackgroundGrob <- circleGrob(x=0.5, y=0.5, r=unit(size+2,"mm"), gp=gpar(fill="lightgrey", col=NA)) - else - circleBackgroundGrob <- nullGrob() - arrow <- arrow(angle = 35, length = unit(size, "mm"), type = "closed") # make arrow description object to be passed to grid.lines - gTree(children=gList( - circleBackgroundGrob, - linesGrob( x = unit(c(.5, .5), "npc") + unit(c(0,size), "mm"), - y = unit(c(.5, .5), "npc"), - arrow = arrow, - gp=gpar(fill=col, lwd=1, col=NA, lineend ="square", - linejoin ="mitre", linemitre=1), - vp=vp), - linesGrob( x = unit(c(.5, .5), "npc") + unit(c(-size/3,0), "mm"), - y = unit(c(.5, .5), "npc"), - gp= gpar(col=col, lwd=2*size, lineend ="square", linejoin ="mitre"), - vp=vp) - ) - ) +# if(hasArg(vp)) vp <- list(...)$vp else vp <- viewport() # if vp is passed use it else create empty viewport +# +# pushViewport(vp) +# pushViewport(viewport(angle=angle)) +# if(circle) grid.circle(x=0.5, y=0.5, r=unit(size+2,"mm"), gp=gpar(fill="lightgrey", col=NA)) +# +# arrow <- arrow(angle = 35, length = unit(size, "mm"), type = "closed") # make arrow object to be passed to grid.lines +# grid.lines( x = unit(c(.5, .5), "npc") + unit(c(0,size), "mm"), +# y = unit(c(.5, .5), "npc"), +# arrow = arrow, +# gp=gpar(fill=col, lwd=1, col=NA, lineend ="square", +# linejoin ="mitre", linemitre=1)) +# grid.lines( x = unit(c(.5, .5), "npc") + unit(c(-size/3,0), "mm"), +# y = unit(c(.5, .5), "npc"), +# gp= gpar(col=col, lwd=2*size, lineend ="square", linejoin ="mitre")) +# popViewport() +# popViewport() +# } + + + +gmArrowIndicatorGrob <- function(angle = 0, col = "black", size = 5, circle = FALSE, initangle = 0, ...) { + # gp <- modifyList(gpar(fill="black", col=NA, lwd=1, lineend ="square", # set default gpar and overwrite if provided + # linejoin ="mitre", linemitre=1), gp) + vp <- viewport(angle = angle + initangle) # created rotated viewport for arrow direction + if (hasArg(vp)) vp <- vpStack(list(...)$vp, vp) # if vp is passed use it and stack the two viewports + if (circle) { + circleBackgroundGrob <- circleGrob(x = 0.5, y = 0.5, r = unit(size + 2, "mm"), gp = gpar(fill = "lightgrey", col = NA)) + } else { + circleBackgroundGrob <- nullGrob() + } + arrow <- arrow(angle = 35, length = unit(size, "mm"), type = "closed") # make arrow description object to be passed to grid.lines + gTree(children = gList( + circleBackgroundGrob, + linesGrob( + x = unit(c(.5, .5), "npc") + unit(c(0, size), "mm"), + y = unit(c(.5, .5), "npc"), + arrow = arrow, + gp = gpar( + fill = col, lwd = 1, col = NA, lineend = "square", + linejoin = "mitre", linemitre = 1 + ), + vp = vp + ), + linesGrob( + x = unit(c(.5, .5), "npc") + unit(c(-size / 3, 0), "mm"), + y = unit(c(.5, .5), "npc"), + gp = gpar(col = col, lwd = 2 * size, lineend = "square", linejoin = "mitre"), + vp = vp + ) + )) } -gmArrowIndicator <- function(angle=0, col="black", size=5, circle=FALSE, initangle=0, ...){ - aiGrob <- gmArrowIndicatorGrob( angle=angle, col=col, size=size, - circle=circle, initangle=initangle, ...) - grid.draw(aiGrob) +gmArrowIndicator <- function(angle = 0, col = "black", size = 5, circle = FALSE, initangle = 0, ...) { + aiGrob <- gmArrowIndicatorGrob( + angle = angle, col = col, size = size, + circle = circle, initangle = initangle, ... + ) + grid.draw(aiGrob) } ## NOT RUN: @@ -538,11 +567,11 @@ gmArrowIndicator <- function(angle=0, col="black", size=5, circle=FALSE, initang # for(j in 1:4){ # vpTmp <- viewport(layout.pos.row=i, layout.pos.col=j) # grid.rect(vp=vpTmp) -# gmArrowIndicator(angleMatrix[i,j], vp=vpTmp) +# gmArrowIndicator(angleMatrix[i,j], vp=vpTmp) # } -# } +# } # popViewport() -# +# # ## array of arrows colored by angle # grid.newpage() # angleMatrix <- matrix(sample(1:360, 100, rep=T), ncol=10) @@ -551,11 +580,11 @@ gmArrowIndicator <- function(angle=0, col="black", size=5, circle=FALSE, initang # for(j in 1:10){ # vpTmp <- viewport(layout.pos.row=i, layout.pos.col=j) # grid.rect(vp=vpTmp) -# gmArrowIndicator(angleMatrix[i,j], col=gmRandomColor(), size=7, vp=vpTmp) +# gmArrowIndicator(angleMatrix[i,j], col=gmRandomColor(), size=7, vp=vpTmp) # } -# } +# } # popViewport() -# +# # ## array of arrows colored by angle # grid.newpage() # angleMatrix <- matrix(1:100*3.6, ncol=10, byrow=T) @@ -565,17 +594,17 @@ gmArrowIndicator <- function(angle=0, col="black", size=5, circle=FALSE, initang # vpTmp <- viewport(layout.pos.row=i, layout.pos.col=j) # grid.rect(vp=vpTmp) # col <- gmSelectColorByValue(angleMatrix[i,j], seq(0, 360, by=10)) -# gmArrowIndicator(angleMatrix[i,j], col=col, size=7, vp=vpTmp) +# gmArrowIndicator(angleMatrix[i,j], col=col, size=7, vp=vpTmp) # } -# } +# } # popViewport() -# +# # ## a frameGrob example # rows <- 10; cols <- 10 # fg <- frameGrob(layout=grid.layout(rows,cols, widths=unit(rep(1.5,cols), "cm"), heights=unit(rep(1.5,rows), "cm"))) # for(i in 1:rows) for (j in 1:cols) fg <- placeGrob(fg, gmArrowIndicatorGrob(), i, j) # grid.draw(fg) -# +# # ## a frameGrob example # rows <- 10; cols <- 10 # angleMatrix <- matrix(1:(rows*cols)*3.6, ncol=cols, byrow=T) @@ -585,38 +614,38 @@ gmArrowIndicator <- function(angle=0, col="black", size=5, circle=FALSE, initang # for (j in 1:cols){ # col <- gmSelectColorByValue(angleMatrix[i,j], seq(0, 360, by=10)) # fg <- placeGrob(fg, gmArrowIndicatorGrob(angle=angleMatrix[i,j], col=col), i, j) -# } +# } # } # grid.draw(fg) -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// -# gmShowPalette +# gmShowPalette # convenient wrapper to look at a palett, taken from colorspace vignette -#gmShowPalette <- function(col, border = "light gray", ...) -#{ -# n <- length(col) -# plot(0, 0, type="n", xlim = c(0, 1), ylim = c(0, 1),axes = FALSE, xlab = "", ylab = "", ...) -# rect(0:(n-1)/n, 0, 1:n/n, 1, col = col, border = border) -#} +# gmShowPalette <- function(col, border = "light gray", ...) +# { +# n <- length(col) +# plot(0, 0, type="n", xlim = c(0, 1), ylim = c(0, 1),axes = FALSE, xlab = "", ylab = "", ...) +# rect(0:(n-1)/n, 0, 1:n/n, 1, col = col, border = border) +# } # gmShowPalette(diverge_hcl(30, h = c(120, 20), c = 70, l = c(55, 98))) # grid based version for better placement -gmShowPalette <- function(col, border = "light gray", ...) -{ - layout <- grid.layout(ncol=length(col)) - fg <- frameGrob(layout=layout, ...) - for(i in seq_along(col)) - fg <- placeGrob(fg, rectGrob(gp=gpar(fill=col[i], col=border)), col=i) - grid.draw(fg) +gmShowPalette <- function(col, border = "light gray", ...) { + layout <- grid.layout(ncol = length(col)) + fg <- frameGrob(layout = layout, ...) + for (i in seq_along(col)) { + fg <- placeGrob(fg, rectGrob(gp = gpar(fill = col[i], col = border)), col = i) + } + grid.draw(fg) } # gmShowPalette(diverge_hcl(30, h = c(120, 20), c = 70, l = c(55, 98))) -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # gmSelectColorByValue # TODO: vectorize, work on matrix, df etc. @@ -624,36 +653,36 @@ gmShowPalette <- function(col, border = "light gray", ...) # if x contains NAs default.na is returned. The default is NA # but a color can be specified in case needed. -gmSelectColorByValue <- function(x, breaks= seq(0, 100, by=10), - colors=diverge_hcl(length(breaks)-1, h = c(120, 20), c = 70, l = c(55, 98)), - default.na=NA) -{ - if(length(breaks)!=(length(colors)+1)) - stop("breaks and colors have to be the same length!") # check if vectors have same length - is.na(x) <- is.na(x) # replacec NaNs by NA - - x <- as.vector(x) - col <- cut(x, breaks=breaks, labels =colors) - col <- colors[as.integer(col)] - col[is.na(col)] <- default.na # replace NAs by default.na - col +gmSelectColorByValue <- function(x, breaks = seq(0, 100, by = 10), + colors = diverge_hcl(length(breaks) - 1, h = c(120, 20), c = 70, l = c(55, 98)), + default.na = NA) { + if (length(breaks) != (length(colors) + 1)) { + stop("breaks and colors have to be the same length!") + } # check if vectors have same length + is.na(x) <- is.na(x) # replacec NaNs by NA + + x <- as.vector(x) + col <- cut(x, breaks = breaks, labels = colors) + col <- colors[as.integer(col)] + col[is.na(col)] <- default.na # replace NAs by default.na + col } # evtl. mal cut2 aus Hmisc anschauen -#gmSelectColorByValue(1:100) -#gmSelectColorByValue(c(NA, NA, 1:9)) -#gmSelectColorByValue(c(NA, NA, 1:9), default.na="#EDEBEB") +# gmSelectColorByValue(1:100) +# gmSelectColorByValue(c(NA, NA, 1:9)) +# gmSelectColorByValue(c(NA, NA, 1:9), default.na="#EDEBEB") -#tmp <- gmSelectColorByValue(1:100, breaks= seq(0, 100, by=5)) -#print(tmp) -#gmShowPalette(tmp) +# tmp <- gmSelectColorByValue(1:100, breaks= seq(0, 100, by=5)) +# print(tmp) +# gmShowPalette(tmp) -#tmp <- gmSelectColorByValue(1:100, c(0,50,100), c("black", "white")) -#print(tmp) -#gmShowPalette(tmp) +# tmp <- gmSelectColorByValue(1:100, c(0,50,100), c("black", "white")) +# print(tmp) +# gmShowPalette(tmp) -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # gmLegends # there is a function for grid legends in vcd package, but it does @@ -662,100 +691,122 @@ gmSelectColorByValue <- function(x, breaks= seq(0, 100, by=10), # WORKING PARTLY BUT STILL UNDER CONSTRUCTION!!! -#library(vcd) -#grid_legend(0.8, 0.9, c("aa","bb"), c("blue", "blue"), c("Port", "Starboard"), title = "SIDE") +# library(vcd) +# grid_legend(0.8, 0.9, c("aa","bb"), c("blue", "blue"), c("Port", "Starboard"), title = "SIDE") -#grid_legend(0.8, 0.9, c(1, 19), c("red", "blue"), +# grid_legend(0.8, 0.9, c(1, 19), c("red", "blue"), # c("Port", "Starboard"), title = "SIDE") -#x=.5 -#y=.5 -#pch=c(1,2) -#col="black" -#labels=c("Text 1", "Text2") -#frame = TRUE -#hgap = unit(0.5, "lines") -#vgap = unit(0.3, "lines") -#default_units = "lines" -#gp = gpar() -#draw = TRUE -#title = "Legend:" +# x=.5 +# y=.5 +# pch=c(1,2) +# col="black" +# labels=c("Text 1", "Text2") +# frame = TRUE +# hgap = unit(0.5, "lines") +# vgap = unit(0.3, "lines") +# default_units = "lines" +# gp = gpar() +# draw = TRUE +# title = "Legend:" # TODO: automatic deterination of wFirstRow by max stringwidth -gmLegend <- function (x, y, pch, symbol=FALSE, col, labels, hgap = unit(0.5, - "lines"), wFirstCol=unit(2,"lines"), vgap = unit(0.3, "lines"), default_units = "lines", - gpRect = gpar(), gpText=gpar(), draw = TRUE, title = "Legend:") -{ - labels <- as.character(labels) - if (is.logical(title) && !title) - title <- NULL - if (!is.null(title)) { - labels <- c(title, labels) - pch <- c(NA, pch) - col <- c(NA, col) - } - nkeys <- length(labels) - if (length(pch) != nkeys) - stop("pch and labels not the same length") - if (!is.unit(hgap)) - hgap <- unit(hgap, default_units) - if (length(hgap) != 1) - stop("hgap must be single unit") - if (!is.unit(vgap)) - vgap <- unit(vgap, default_units) - if (length(vgap) != 1) - stop("vgap must be single unit") - - legend.layout <- grid.layout(nkeys, 3, - widths = unit.c(wFirstCol, max(unit(rep(1, nkeys), - "strwidth", as.list(labels))), hgap), - heights = unit.pmax(unit(1, "lines"), vgap + unit(rep(1, nkeys), - "strheight", as.list(labels)))) - fg <- frameGrob(layout = legend.layout, gp = gpText) - # background col - fg <- placeGrob(fg, rectGrob(gp = gpRect)) - - for (i in 1:nkeys) { - tit <- !is.null(title) && i == 1 - if (!tit) - if(symbol) { # print text if symbol is FALSE (default) - fg <- placeGrob(fg, pointsGrob(0.5, 0.5, pch = pch[i], - gp = gpar(col = col[i])), col = 1, row = i) - } else { - fg <- placeGrob(fg, textGrob(label= pch[i], x=0.1, y=0.5, - gp = gpar(col = col[i]), just = c("left", "center")), - col = 1, row = i) - } - fg <- placeGrob(fg, textGrob(labels[i], x = 0 + 0.3 * - tit, y = 0.5, just = c("left", "center")), col = 2 - - tit, row = i) +gmLegend <- function( + x, y, pch, symbol = FALSE, col, labels, hgap = unit( + 0.5, + "lines" + ), wFirstCol = unit(2, "lines"), vgap = unit(0.3, "lines"), default_units = "lines", + gpRect = gpar(), gpText = gpar(), draw = TRUE, title = "Legend:") { + labels <- as.character(labels) + if (is.logical(title) && !title) { + title <- NULL + } + if (!is.null(title)) { + labels <- c(title, labels) + pch <- c(NA, pch) + col <- c(NA, col) + } + nkeys <- length(labels) + if (length(pch) != nkeys) { + stop("pch and labels not the same length") + } + if (!is.unit(hgap)) { + hgap <- unit(hgap, default_units) + } + if (length(hgap) != 1) { + stop("hgap must be single unit") + } + if (!is.unit(vgap)) { + vgap <- unit(vgap, default_units) + } + if (length(vgap) != 1) { + stop("vgap must be single unit") + } + + legend.layout <- grid.layout(nkeys, 3, + widths = unit.c(wFirstCol, max(unit( + rep(1, nkeys), + "strwidth", as.list(labels) + )), hgap), + heights = unit.pmax(unit(1, "lines"), vgap + unit( + rep(1, nkeys), + "strheight", as.list(labels) + )) + ) + fg <- frameGrob(layout = legend.layout, gp = gpText) + # background col + fg <- placeGrob(fg, rectGrob(gp = gpRect)) + + for (i in 1:nkeys) { + tit <- !is.null(title) && i == 1 + if (!tit) { + if (symbol) { # print text if symbol is FALSE (default) + fg <- placeGrob(fg, pointsGrob(0.5, 0.5, + pch = pch[i], + gp = gpar(col = col[i]) + ), col = 1, row = i) + } else { + fg <- placeGrob(fg, textGrob( + label = pch[i], x = 0.1, y = 0.5, + gp = gpar(col = col[i]), just = c("left", "center") + ), + col = 1, row = i + ) + } } - pushViewport(viewport(x, y, height = unit(nkeys, "lines"), - width = grobWidth(fg))) -# if (frame) -# fg <- placeGrob(fg, rectGrob(gp = gpar(fill = "transparent"))) - if (draw) - grid.draw(fg) - popViewport(1) - invisible(fg) + fg <- placeGrob(fg, textGrob(labels[i], x = 0 + 0.3 * + tit, y = 0.5, just = c("left", "center")), col = 2 - + tit, row = i) + } + pushViewport(viewport(x, y, + height = unit(nkeys, "lines"), + width = grobWidth(fg) + )) + # if (frame) + # fg <- placeGrob(fg, rectGrob(gp = gpar(fill = "transparent"))) + if (draw) { + grid.draw(fg) + } + popViewport(1) + invisible(fg) } -#labels=1:20 +# labels=1:20 # legend with symbols -#gmLegend(x=0.25, y=0.5, symbol=TRUE, pch=seq_along(labels), col=rep("blue", length(labels)), +# gmLegend(x=0.25, y=0.5, symbol=TRUE, pch=seq_along(labels), col=rep("blue", length(labels)), # labels=labels, gpText=gpar(cex=.7), title = "Test 1") # without frame -#gmLegend(x=0.5, y=0.5, symbol=TRUE, pch=seq_along(labels), col=rep("brown", length(labels)), +# gmLegend(x=0.5, y=0.5, symbol=TRUE, pch=seq_along(labels), col=rep("brown", length(labels)), # labels=labels, gpText=gpar(cex=.7, col=grey(.7)), gpRect=gpar(col=NA), title = "Test 2") # legend with multi-character index column -#gmLegend(x=0.75, y=0.5, wFirstCol=unit(3, "lines"), hgap = unit(1, "lines"), -# pch=paste(LETTERS[1:20], labels, sep=""), labels=LETTERS[1:20], col=rep(rainbow(20), length(labels)), -# gpRect=gpar(col=1, fill=grey(.95), lty=3), gpText=gpar(col=grey(.5), cex=.7), title = NULL) +# gmLegend(x=0.75, y=0.5, wFirstCol=unit(3, "lines"), hgap = unit(1, "lines"), +# pch=paste(LETTERS[1:20], labels, sep=""), labels=LETTERS[1:20], col=rep(rainbow(20), length(labels)), +# gpRect=gpar(col=1, fill=grey(.95), lty=3), gpText=gpar(col=grey(.5), cex=.7), title = NULL) -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # gmLegends_2 # there is a function for grid legends in vcd package, but it does @@ -765,131 +816,121 @@ gmLegend <- function (x, y, pch, symbol=FALSE, col, labels, hgap = unit(0.5, # TODO: placeGrob nutzen sowie Spalten und Zeilenhöhe berechnen! # background wird im moment einfach noch gezeichnet ohne args! -gmLegend2 <- function(colors, labels, ncol=NA, nrow=NA, byrow=TRUE, - symbolSize=unit(3, "mm"), symbolMargin=unit(2, "mm"), - bg=1, na.bg =TRUE, force.height=FALSE, dynamic=TRUE) -{ -#args: -#byrow=T -#ncol=NA -#nrow=1 -#colors <- rainbow(10) -##labels <- LETTERS[1:10] -#labels <- sapply(1:10, getRandString) -##args: -#symbolSize <- unit(3, "mm") -#symbolMargin <- unit(2, "mm") -#bg <- 1 -#na.bg =TRUE # draw background in NA (unused) cells? - - # input check - if(length(labels) != length(colors)) # do colors match labels? - stop("Same length of colors and labels required!") - if(length(colors)==1 & length(labels) > 1) # one color many labels -> recycle color - colors <- rep(colors, length(labels)) - if(sum(is.na(c(ncol, nrow))) != 1 | - !is.numeric(c(ncol, nrow))) stop("Please specify ncol OR nrow as positive integer.") - noCells <- length(labels) - - # calcs: determine matrix size - if(is.na(nrow)) nrow <- noCells %/% ncol + (noCells %% ncol != 0) # needed no of rows - if(is.na(ncol)) ncol <- noCells %/% nrow + (noCells %% nrow != 0) # needed no of cols - - # missing cells are given NAs - if(noCells != ncol * nrow){ - labels <- c(labels, rep(NA, ncol * nrow - noCells)) - colors <- c(colors, rep(NA, ncol * nrow - noCells)) - } - labelsMat <- matrix(labels, ncol=ncol, nrow=nrow, byrow=byrow) - colorsMat <- matrix(colors, ncol=ncol, nrow=nrow, byrow=byrow) - #labelsMat; colorsMat - - # filling the layout - labelCell <- function(label){ - gTree(children=gList( - gmSplitTextGrob(label, - x=unit(2, "mm"), - y=unit(.5, "npc"), - just=c("left", "center"), - gp=gpar(lineheight=.7, cex=.8)) - )) - } - - symbolCell <- function(fill, col="black"){ - gTree(children=gList( - rectGrob(width=symbolSize, height=symbolSize, - gp=gpar(fill=fill, col=col)) - )) - } - - backgroundCell <- function(gp=gpar()){ - gTree(children=gList( - rectGrob(width=1, height=1, gp=gp) - )) - } - - # make layout and frame - layout <- grid.layout(nrow=nrow, ncol = ncol*2, - widths=unit(rep(c(7,1), ncol), rep(c("mm", "null"), ncol)), - heights=unit(rep(1, nrow), "lines")) - fg <- frameGrob(layout=layout, name="topFrame") - - # make and add background object - bgCell <- rectGrob(gp=gpar(fill=grey(0.6), col="white", lwd=5)) - fg <- packGrob(fg, bgCell, dynamic=dynamic, force.height=force.height) - - # fill frame - for(i in 1:nrow){ - for(j in 1:(ncol)){ - bgGrob <- backgroundCell(gpar(fill=grey(.95), col="white")) - draw.bg <- !(is.na(labelsMat[i,j]) & !na.bg) - if(bg==1 & draw.bg) - fg <- packGrob(fg, bgGrob, col=(2*j-1):(2*j), row=i, dynamic=dynamic, force.height=force.height) - if(bg==2 & draw.bg){ - fg <- packGrob(fg, bgGrob, col=(2*j-1), row=i, dynamic=dynamic, force.height=force.height) - fg <- packGrob(fg, bgGrob, col=(2*j), row=i, dynamic=dynamic, force.height=force.height) - } - - if(!is.na(colorsMat[i,j])){ - symbolGrob <- symbolCell(colorsMat[i,j], col=NA) - fg <- packGrob(fg, symbolGrob, col=2*j-1, row=i, dynamic=dynamic, force.height=force.height) - } - if(!is.na(labelsMat[i,j])){ - cellGrob <- labelCell(labelsMat[i,j]) - fg <- packGrob(fg, cellGrob, col=(2*j), row=i, dynamic=dynamic, force.height=force.height) - } - } - } - return(fg) +gmLegend2 <- function(colors, labels, ncol = NA, nrow = NA, byrow = TRUE, + symbolSize = unit(3, "mm"), symbolMargin = unit(2, "mm"), + bg = 1, na.bg = TRUE, force.height = FALSE, dynamic = TRUE) { + # args: + # byrow=T + # ncol=NA + # nrow=1 + # colors <- rainbow(10) + ## labels <- LETTERS[1:10] + # labels <- sapply(1:10, getRandString) + ## args: + # symbolSize <- unit(3, "mm") + # symbolMargin <- unit(2, "mm") + # bg <- 1 + # na.bg =TRUE # draw background in NA (unused) cells? + + # input check + if (length(labels) != length(colors)) { # do colors match labels? + stop("Same length of colors and labels required!") + } + if (length(colors) == 1 & length(labels) > 1) { # one color many labels -> recycle color + colors <- rep(colors, length(labels)) + } + if (sum(is.na(c(ncol, nrow))) != 1 | + !is.numeric(c(ncol, nrow))) { + stop("Please specify ncol OR nrow as positive integer.") + } + noCells <- length(labels) + + # calcs: determine matrix size + if (is.na(nrow)) nrow <- noCells %/% ncol + (noCells %% ncol != 0) # needed no of rows + if (is.na(ncol)) ncol <- noCells %/% nrow + (noCells %% nrow != 0) # needed no of cols + + # missing cells are given NAs + if (noCells != ncol * nrow) { + labels <- c(labels, rep(NA, ncol * nrow - noCells)) + colors <- c(colors, rep(NA, ncol * nrow - noCells)) + } + labelsMat <- matrix(labels, ncol = ncol, nrow = nrow, byrow = byrow) + colorsMat <- matrix(colors, ncol = ncol, nrow = nrow, byrow = byrow) + # labelsMat; colorsMat + + # filling the layout + labelCell <- function(label) { + gTree(children = gList( + gmSplitTextGrob(label, + x = unit(2, "mm"), + y = unit(.5, "npc"), + just = c("left", "center"), + gp = gpar(lineheight = .7, cex = .8) + ) + )) + } + + symbolCell <- function(fill, col = "black") { + gTree(children = gList( + rectGrob( + width = symbolSize, height = symbolSize, + gp = gpar(fill = fill, col = col) + ) + )) + } + + backgroundCell <- function(gp = gpar()) { + gTree(children = gList( + rectGrob(width = 1, height = 1, gp = gp) + )) + } + + # make layout and frame + layout <- grid.layout( + nrow = nrow, ncol = ncol * 2, + widths = unit(rep(c(7, 1), ncol), rep(c("mm", "null"), ncol)), + heights = unit(rep(1, nrow), "lines") + ) + fg <- frameGrob(layout = layout, name = "topFrame") + + # make and add background object + bgCell <- rectGrob(gp = gpar(fill = grey(0.6), col = "white", lwd = 5)) + fg <- packGrob(fg, bgCell, dynamic = dynamic, force.height = force.height) + + # fill frame + for (i in 1:nrow) { + for (j in 1:(ncol)) { + bgGrob <- backgroundCell(gpar(fill = grey(.95), col = "white")) + draw.bg <- !(is.na(labelsMat[i, j]) & !na.bg) + if (bg == 1 & draw.bg) { + fg <- packGrob(fg, bgGrob, col = (2 * j - 1):(2 * j), row = i, dynamic = dynamic, force.height = force.height) + } + if (bg == 2 & draw.bg) { + fg <- packGrob(fg, bgGrob, col = (2 * j - 1), row = i, dynamic = dynamic, force.height = force.height) + fg <- packGrob(fg, bgGrob, col = (2 * j), row = i, dynamic = dynamic, force.height = force.height) + } + + if (!is.na(colorsMat[i, j])) { + symbolGrob <- symbolCell(colorsMat[i, j], col = NA) + fg <- packGrob(fg, symbolGrob, col = 2 * j - 1, row = i, dynamic = dynamic, force.height = force.height) + } + if (!is.na(labelsMat[i, j])) { + cellGrob <- labelCell(labelsMat[i, j]) + fg <- packGrob(fg, cellGrob, col = (2 * j), row = i, dynamic = dynamic, force.height = force.height) + } + } + } + return(fg) } -#fg <- gmLegend2(rainbow(7), letters[1:7], ncol=3, bg=0) -#pushViewport(viewport(y=.3,height=unit(10, "mm"), width=.4)) -# grid.draw(fg) -#popViewport() - -#getRandString <- function(len=12) return(paste(sample(c(rep(0:9, each=5), LETTERS,letters, rep(c(" "), 10)),len,replace=TRUE),collapse='')) -#fg <- gmLegend2(rainbow(10), sapply(1:10, getRandString), ncol=3, byrow=F) -#pushViewport(viewport(y=.3,height=unit(10, "mm"), width=.4))# -# grid.draw(fg) -#popViewport() - - - - - - - - - - - - - - - - - - +# fg <- gmLegend2(rainbow(7), letters[1:7], ncol=3, bg=0) +# pushViewport(viewport(y=.3,height=unit(10, "mm"), width=.4)) +# grid.draw(fg) +# popViewport() +# getRandString <- function(len=12) return(paste(sample(c(rep(0:9, each=5), LETTERS,letters, rep(c(" "), 10)),len,replace=TRUE),collapse='')) +# fg <- gmLegend2(rainbow(10), sapply(1:10, getRandString), ncol=3, byrow=F) +# pushViewport(viewport(y=.3,height=unit(10, "mm"), width=.4))# +# grid.draw(fg) +# popViewport() diff --git a/R/import.r b/R/import.r index 4129230e..1eb592cd 100644 --- a/R/import.r +++ b/R/import.r @@ -1,5 +1,4 @@ - -################### import repgrid data from other (grid) programs ############ +################### import repgrid data from other (grid) programs ############ # # programs currently supported: # @@ -14,25 +13,25 @@ # .txt # # Not supported: -# - Excel is not supported as it is no genuine grid program. It can be easily -# used though to produce grid data that can be imported. +# - Excel is not supported as it is no genuine grid program. It can be easily +# used though to produce grid data that can be imported. # #' convertImportObjectToRepGridObject. #' -#' Convert the returned object from an import function into a `repgrid` +#' Convert the returned object from an import function into a `repgrid` #' object. Works for all importXInternal functions (except scivesco). -#' +#' #' @param x object returned from an import function. #' @return `repgrid` object. #' @keywords internal #' @export #' -convertImportObjectToRepGridObject <- function(import){ +convertImportObjectToRepGridObject <- function(import) { # structure of import object: - # + # # List of 9 # $ elements :List of 3 # $ constructs :List of 4 @@ -45,20 +44,21 @@ convertImportObjectToRepGridObject <- function(import){ # $ maxValue : num 1 args <- list( - name = unlist(import$elements), # elements - l.name = unlist(import$emergentPoles), # left poles - r.name = unlist(import$contrastPoles), # right poles - scores = sapply(import$ratings, I)) # ratings - x <- makeRepgrid(args) # make repgrid - x <- setScale(x, import$minValue, import$maxValue) # set scale range - x + name = unlist(import$elements), # elements + l.name = unlist(import$emergentPoles), # left poles + r.name = unlist(import$contrastPoles), # right poles + scores = sapply(import$ratings, I) + ) # ratings + x <- makeRepgrid(args) # make repgrid + x <- setScale(x, import$minValue, import$maxValue) # set scale range + x } ############################ GRIDSTAT ######################################### # gridstat output has the following form. -# 1) first line: some description elements. +# 1) first line: some description elements. # 2) second line: number of constructs and elements # 3) next n lines: constructs, elements # 4) matrix of ratings @@ -93,7 +93,7 @@ convertImportObjectToRepGridObject <- function(import){ # irene # childhood self # self before illness -# self with delusion +# self with delusion # self as dreamer # 1 4 2 2 3 5 2 5 4 2 6 2 2 3 3 # 3 6 3 5 5 4 5 4 5 4 4 4 2 2 3 @@ -113,13 +113,13 @@ convertImportObjectToRepGridObject <- function(import){ #' Parser for Gridstat data files. #' -#' Parse the file format that is used by the latest version of grid program +#' Parse the file format that is used by the latest version of grid program #' gridstat (Bell, 1998). #' -#' @param file filename including path if file is not in current working +#' @param file filename including path if file is not in current working #' directory. File can also be a complete URL. The fileformat #' is .dat. -#' @param dir alternative way to supply the directory where the file is located +#' @param dir alternative way to supply the directory where the file is located #' (default `NULL`). #' @param min optional argument (`numeric`, default `NULL`) #' for minimum rating value in grid. @@ -127,208 +127,230 @@ convertImportObjectToRepGridObject <- function(import){ #' for maximum rating value in grid. #' @return a list with imported parameters #' -#' @note Note that the gridstat data format does not contain explicit -#' information about the range of the rating scale (minimum and +#' @note Note that the gridstat data format does not contain explicit +#' information about the range of the rating scale (minimum and #' maximum). By default the range is inferred by scanning #' the ratings and picking the minimal and maximal values as rating -#' range. You can set the minimal and maximal value by hand using the `min` and +#' range. You can set the minimal and maximal value by hand using the `min` and #' `max` arguments or by using the `setScale()` function. #' Note that if the rating range is not set, it may cause several #' functions to not work properly. A warning will be issued if the range is #' not set explicitly when using the importing function. -#' +#' #' The function only reads data from the latest GridStat version. #' The latest version allows the separation of the left and right pole #' by using on of the following symbols `/:-` (hyphen, colon and dash). Older versions may not -#' separate the left and right pole. This will cause all labels to be assigned to +#' separate the left and right pole. This will cause all labels to be assigned to #' the left pole only when importing. You may fix this by simply entering #' one of the construct separator symbols into the GridStat file between each #' left and right construct pole. #' #' The third line of a GridStat file may contain a no labels statement (i.e. a #' line containing any string of 'NOLA', 'NO L', 'NoLa', 'No L', 'Nola', 'No l', -#' 'nola' or 'no l'). In this case only ratings are supplied, hence, default +#' 'nola' or 'no l'). In this case only ratings are supplied, hence, default #' names are assigned to elements and constructs. #' -#' Email from Richard: The gridstat file has a fixed format with a title line, number -#' of constructs and elements on second line. The third line can say No labels +#' Email from Richard: The gridstat file has a fixed format with a title line, number +#' of constructs and elements on second line. The third line can say No labels #' (actually it looks at the first 4 characters which can be any of 'NOLA','NO L', -#' 'NoLa','No L','Nola','No l','nola','no l') in which case it skips to the data and -#' creates dummy labels for elements and constructs, otherwise it reads the construct -#' labels then the element labels, then the data. Construct labels were originally -#' stored as one, hence it didn't matter what the separator between left and right -#' pole labels was, but in the latest version where constructs can be reversed, it -#' looks for a fixed separator - one of slash(/), dash(-), or colon(:). Some of my +#' 'NoLa','No L','Nola','No l','nola','no l') in which case it skips to the data and +#' creates dummy labels for elements and constructs, otherwise it reads the construct +#' labels then the element labels, then the data. Construct labels were originally +#' stored as one, hence it didn't matter what the separator between left and right +#' pole labels was, but in the latest version where constructs can be reversed, it +#' looks for a fixed separator - one of slash(/), dash(-), or colon(:). Some of my #' old data files might not conform. #' #' @export #' @keywords internal -#' @references Bell, R. C. (1998) GRIDSTAT: A program for analyzing the data of a +#' @references Bell, R. C. (1998) GRIDSTAT: A program for analyzing the data of a #' repertory grid. Melbourne: Author. #' @examples \dontrun{ -#' +#' #' # supposing that the data file gridstat.dat is in the current working directory #' file <- "gridstat.dat" #' imp <- importGridstatInternal(file) -#' +#' #' # specifying a directory (example) #' dir <- "/Users/markheckmann/data" #' imp <- importGridstatInternal(file, dir) -#' +#' #' # using a full path (example) #' imp <- importGridstatInternal("/Users/markheckmann/data/gridstat.dat") -#' +#' #' # setting rating scale range -#' imp <- importGridstatInternal(file, dir, min=1, max=6) +#' imp <- importGridstatInternal(file, dir, min = 1, max = 6) #' } #' -importGridstatInternal <- function(file, dir=NULL, min=NULL, max=NULL){ - if (!is.null(dir)) - file <- paste(dir, file, sep="/", collapse="") - - # read meta info - l <- list() # list object to store all data in - datainfo <- scan(file = file, what = "raw", # Read information line (first line) - skip=0, nlines=1, quiet = TRUE) - l$datainfo <- joinString(datainfo) # join single items to long string - noConstructAndElements <- scan(file = file, what = "integer", - skip=1, nlines=1, quiet = TRUE) # Read number of elements and constructs - l$noConstructs <- as.numeric(noConstructAndElements)[1] # no of constructs - l$noElements <- as.numeric(noConstructAndElements)[2] # no of elements - l$minValue <- NA - l$maxValue <- NA - - # third line may contain a "no labels" statement in the first four characters. - # In that case default labels are used and only the data is read (see email Richard). - # No labels statement may be one of c('NOLA','NO L','NoLa','No L','Nola','No l','nola','no l'). - thirdLine <- scan(file = file, what = "character", - skip=2, nlines=1, quiet = TRUE) # read third line of file - thirdLine <- joinString(thirdLine) - firstFourChars <- substr(thirdLine, 1, 4) # extract first four chracters - noLabels <- firstFourChars %in% c('NOLA','NO L','NoLa','No L', - 'Nola','No l','nola','no l') # does third line have a no labels statement? - - # read constructs - l$constructs <- list() - l$emergentPoles <- list() - l$contrastPoles <- list() - if (!noLabels) { # read constructs if no labels statement is absent - for (i in 1:l$noConstructs){ - tmp <- scan(file = file, what = "character", - skip=2+i-1, nlines=1, quiet = TRUE) # read construct line by line - l$constructs[[i]] <- joinString(tmp) # make one string - poles <- strsplit(l$constructs[[i]], "[/:-]") # separate emergent and contrast pole by splitting at hyphen, colon or slash (see email from Richard) - l$emergentPoles[[i]] <- trimBlanksInString(poles[[1]][1]) # save emergent pole - l$contrastPoles[[i]] <- trimBlanksInString(poles[[1]][2]) # save contrast pole - } - } else { # make default constructs if no labels statement given +importGridstatInternal <- function(file, dir = NULL, min = NULL, max = NULL) { + if (!is.null(dir)) { + file <- paste(dir, file, sep = "/", collapse = "") + } + + # read meta info + l <- list() # list object to store all data in + datainfo <- scan( + file = file, what = "raw", # Read information line (first line) + skip = 0, nlines = 1, quiet = TRUE + ) + l$datainfo <- joinString(datainfo) # join single items to long string + noConstructAndElements <- scan( + file = file, what = "integer", + skip = 1, nlines = 1, quiet = TRUE + ) # Read number of elements and constructs + l$noConstructs <- as.numeric(noConstructAndElements)[1] # no of constructs + l$noElements <- as.numeric(noConstructAndElements)[2] # no of elements + l$minValue <- NA + l$maxValue <- NA + + # third line may contain a "no labels" statement in the first four characters. + # In that case default labels are used and only the data is read (see email Richard). + # No labels statement may be one of c('NOLA','NO L','NoLa','No L','Nola','No l','nola','no l'). + thirdLine <- scan( + file = file, what = "character", + skip = 2, nlines = 1, quiet = TRUE + ) # read third line of file + thirdLine <- joinString(thirdLine) + firstFourChars <- substr(thirdLine, 1, 4) # extract first four chracters + noLabels <- firstFourChars %in% c( + "NOLA", "NO L", "NoLa", "No L", + "Nola", "No l", "nola", "no l" + ) # does third line have a no labels statement? + + # read constructs + l$constructs <- list() + l$emergentPoles <- list() + l$contrastPoles <- list() + if (!noLabels) { # read constructs if no labels statement is absent + for (i in 1:l$noConstructs) { + tmp <- scan( + file = file, what = "character", + skip = 2 + i - 1, nlines = 1, quiet = TRUE + ) # read construct line by line + l$constructs[[i]] <- joinString(tmp) # make one string + poles <- strsplit(l$constructs[[i]], "[/:-]") # separate emergent and contrast pole by splitting at hyphen, colon or slash (see email from Richard) + l$emergentPoles[[i]] <- trimBlanksInString(poles[[1]][1]) # save emergent pole + l$contrastPoles[[i]] <- trimBlanksInString(poles[[1]][2]) # save contrast pole + } + } else { # make default constructs if no labels statement given constructs.left <- paste("construct left", seq_len(l$noConstructs)) constructs.right <- paste("construct right", seq_len(l$noConstructs)) - l$constructs <- as.list( paste(constructs.left, constructs.right, sep=" - ") ) + l$constructs <- as.list(paste(constructs.left, constructs.right, sep = " - ")) l$emergentPoles <- as.list(constructs.left) l$contrastPoles <- as.list(constructs.right) } - - # read elements - l$elements <- list() - if (!noLabels) { # read element names in the default case where labels are supplied - for (i in 1:l$noElements){ - tmp <- scan(file = file, what = "character", # read elements line by line - skip=2+l$noConstructs+(i-1), - nlines=1, quiet = TRUE) - l$elements[[i]] <- trimBlanksInString(joinString(tmp)) - } - } else { # make default element names if no labels statement given - l$elements <- as.list( paste("element", seq_len(l$noElements)) ) + + # read elements + l$elements <- list() + if (!noLabels) { # read element names in the default case where labels are supplied + for (i in 1:l$noElements) { + tmp <- scan( + file = file, what = "character", # read elements line by line + skip = 2 + l$noConstructs + (i - 1), + nlines = 1, quiet = TRUE + ) + l$elements[[i]] <- trimBlanksInString(joinString(tmp)) + } + } else { # make default element names if no labels statement given + l$elements <- as.list(paste("element", seq_len(l$noElements))) + } + + # read ratings + if (!noLabels) { # default case (labels supplied) + skipLines.ratings <- 2 + l$noElements + l$noConstructs + } else { # different starting position for reading of ratings in case of no labels statement + skipLines.ratings <- 3 # skipping 1) info, 2) number of e and c and 3) no labels statement lines. + } + + l$ratings <- list() + for (i in 1:l$noConstructs) { + tmp <- scan( + file = file, what = "character", quiet = TRUE, + skip = skipLines.ratings + (i - 1), # read ratings line by line + nlines = 1 + ) + l$ratings[[i]] <- as.numeric(tmp) + } + + # infer maximum rating value if not provided in max argument + if (is.null(min)) { + l$minValue <- min(unlist(l$ratings), na.rm = TRUE) + } else { + l$minValue <- min + } + + if (is.null(max)) { + l$maxValue <- max(unlist(l$ratings), na.rm = TRUE) + } else { + l$maxValue <- max + } + + if (is.null(min) | is.null(max)) { + warning("the minimum and/or the maximum value of the rating scale have not been set explicitly.", + "The scale range was thus inferred by scanning the available ratings and may be wrong.", + "See ?importGridstat for more information", + call. = FALSE + ) } - - # read ratings - if (!noLabels) { # default case (labels supplied) - skipLines.ratings <- 2 + l$noElements + l$noConstructs - } else { # different starting position for reading of ratings in case of no labels statement - skipLines.ratings <- 3 # skipping 1) info, 2) number of e and c and 3) no labels statement lines. - } - - l$ratings <- list() - for (i in 1:l$noConstructs){ - tmp <- scan(file = file, what = "character", quiet = TRUE, - skip= skipLines.ratings + (i-1), # read ratings line by line - nlines=1) - l$ratings[[i]] <- as.numeric(tmp) - } - - # infer maximum rating value if not provided in max argument - if (is.null(min)) { - l$minValue <-min(unlist(l$ratings), na.rm=TRUE) - } else l$minValue <- min - - if (is.null(max)) { - l$maxValue <-max(unlist(l$ratings), na.rm=TRUE) - } else l$maxValue <- max - - if (is.null(min) | is.null(max)){ - warning("the minimum and/or the maximum value of the rating scale have not been set explicitly.", - "The scale range was thus inferred by scanning the available ratings and may be wrong.", - "See ?importGridstat for more information", call. = FALSE) - } - l + l } # Richards file -#file <- "/Users/unimitarbeiter/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/gridstat.dat" -#file <- "/Users/markheckmann/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/gridstat.dat" +# file <- "/Users/unimitarbeiter/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/gridstat.dat" +# file <- "/Users/markheckmann/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/gridstat.dat" # "No labels" file -#file <- "/Users/markheckmann/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/gridstat_nolabels.dat" -#file <- "/Users/unimitarbeiter/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/gridstat_nolabels.dat" +# file <- "/Users/markheckmann/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/gridstat_nolabels.dat" +# file <- "/Users/unimitarbeiter/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/gridstat_nolabels.dat" #' Converts a Gridstat multigrid file into temporary single grid files and #' returns their path -#' +#' #' The format for a multigrid file resembles the single Gridstat data file. The #' lines of the single files are simply placed below each other without any #' blank lines in between. The function reads in a file and tests if it is a #' multigrid file. Multigrid files are separated into single Gridstat temp #' files. The file path for the temp files is returned. If the file is a single #' grid files the path is left unaltered. -#' +#' #' @param file Filenames of Gridstat file #' @return A vector containing the paths to the temp files #' @export #' @keywords internal -#' -multigridFileToSinglegridFiles <- function(file) -{ +#' +multigridFileToSinglegridFiles <- function(file) { l <- readLines(file) - r <- grepl("^[ \t]*[0-9]+[ \t]+[0-9]+ *$", l) # lines with number of c and e, i.e. two digits separated by space - is.multigrid.file <- sum(r) > 1 # check if it is a multi-grid file + r <- grepl("^[ \t]*[0-9]+[ \t]+[0-9]+ *$", l) # lines with number of c and e, i.e. two digits separated by space + is.multigrid.file <- sum(r) > 1 # check if it is a multi-grid file if (is.multigrid.file) { - pos <- which(r) -1 # subtract 1 as it is preceeded by an info line, i.e. where the grid starts - pos.ext <- c(pos, length(l) + 1) # add last position + pos <- which(r) - 1 # subtract 1 as it is preceeded by an info line, i.e. where the grid starts + pos.ext <- c(pos, length(l) + 1) # add last position tmp.files <- vector("character") - for (i in seq_along(pos)) { # save single grids to temp files - lines <- l[pos.ext[i]:(pos.ext[i+1] - 1)] # read info for single grid - tmp.file <- tempfile("importGridstat_", - fileext=".dat") # generate temp file - writeLines(lines, tmp.file) # write grid to temp file - tmp.files <- c(tmp.files, tmp.file) # vector of temp file names - } + for (i in seq_along(pos)) { # save single grids to temp files + lines <- l[pos.ext[i]:(pos.ext[i + 1] - 1)] # read info for single grid + tmp.file <- tempfile("importGridstat_", + fileext = ".dat" + ) # generate temp file + writeLines(lines, tmp.file) # write grid to temp file + tmp.files <- c(tmp.files, tmp.file) # vector of temp file names + } return(tmp.files) - } else - return(file) + } else { + return(file) + } } #' Import Gridstat data files. #' -#' Reads the file format that is used by the latest version of the grid +#' Reads the file format that is used by the latest version of the grid #' program gridstat (Bell, 1998). #' -#' @param file Filename including path if file is not in current working +#' @param file Filename including path if file is not in current working #' directory. File can also be a complete URL. The fileformat #' is `.dat`. -#' @param dir Alternative way to supply the directory where the file is located +#' @param dir Alternative way to supply the directory where the file is located #' (default `NULL`). #' @param min Optional argument (`numeric`, default `NULL`) #' for minimum rating value in grid. @@ -336,7 +358,7 @@ multigridFileToSinglegridFiles <- function(file) #' for maximum rating value in grid. #' @return A single `repgrid` object in case one file and a list of `repgrid` objects in case multiple files are #' imported. -#' +#' #' @note Note that the gridstat data format does not contain explicit information about the range of the rating scale #' used (minimum and maximum). By default the range is inferred by scanning the ratings and picking the minimal and #' maximal values as rating range. You can set the minimal and maximal value by hand using the `min` and `max` @@ -361,32 +383,35 @@ multigridFileToSinglegridFiles <- function(file) #' [importExcel()] #' #' @examples \dontrun{ -#' +#' #' # supposing that the data file gridstat.dat is in the current working directory #' file <- "gridstat.dat" #' rg <- importGridstat(file) -#' +#' #' # specifying a directory (example) #' dir <- "/Users/markheckmann/data" #' rg <- importGridstat(file, dir) -#' +#' #' # using a full path (example) #' rg <- importGridstat("/Users/markheckmann/data/gridstat.dat") -#' +#' #' # setting rating scale range -#' rg <- importGridstat(file, dir, min=1, max=6) +#' rg <- importGridstat(file, dir, min = 1, max = 6) #' } #' -importGridstat <- function(file, dir=NULL, min=NULL, max=NULL) { - tmp.files <- unlist(lapply(as.list(file), # convert multigrid files to single grid files - multigridFileToSinglegridFiles)) - imps <- lapply(as.list(tmp.files), importGridstatInternal, # make import objects for each .txt file - dir=dir, min=min, max=max) - rgs <- lapply(imps, convertImportObjectToRepGridObject) # make repgrid object from import object +importGridstat <- function(file, dir = NULL, min = NULL, max = NULL) { + tmp.files <- unlist(lapply( + as.list(file), # convert multigrid files to single grid files + multigridFileToSinglegridFiles + )) + imps <- lapply(as.list(tmp.files), importGridstatInternal, # make import objects for each .txt file + dir = dir, min = min, max = max + ) + rgs <- lapply(imps, convertImportObjectToRepGridObject) # make repgrid object from import object if (length(tmp.files) == 1) { - return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted + return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted } else { - return(rgs) # return a list of repgrid objects + return(rgs) # return a list of repgrid objects } } @@ -395,15 +420,15 @@ importGridstat <- function(file, dir=NULL, min=NULL, max=NULL) { ############################# GRIDCOR ######################################### # gridcor outpout has the following form: -# "As you can see in this sample file, the first line contains the number of constructs (10), -# of elements (13) and the maximum scale range (7), separated by two spaces each. The second -# line is the title of the analysis. Next is the data matrix itself, and the labels: first, -# the element labels, then the labels of the right poles of the constructs, and finally the +# "As you can see in this sample file, the first line contains the number of constructs (10), +# of elements (13) and the maximum scale range (7), separated by two spaces each. The second +# line is the title of the analysis. Next is the data matrix itself, and the labels: first, +# the element labels, then the labels of the right poles of the constructs, and finally the # left pole ones." # as retrieved from http://www.terapiacognitiva.net/record/manualgri/man3.htm on 07/Sep/2010 # 14 15 6 -# Heinz Boeker in Scheer & Catina (1996, p.163) +# Heinz Boeker in Scheer & Catina (1996, p.163) # 122352542622334 # 335545454442236 # 223532323344532 @@ -467,78 +492,87 @@ importGridstat <- function(file, dir=NULL, min=NULL, max=NULL) { #' #' Parse the file format that is used by the grid program GRIDCOR (Feixas & Cornejo). #' -#' @param file filename including path if file is not in current working +#' @param file filename including path if file is not in current working #' directory. File can also be a complete URL. The fileformat #' is .dat. -#' @param dir alternative way to supply the directory where the file is located +#' @param dir alternative way to supply the directory where the file is located #' (default `NULL`). #' @note Note that the GRIDCOR data sets the minimum ratings scale range to 1. -#' The maximum value can differ and is defined in the data file. +#' The maximum value can differ and is defined in the data file. #' @references #' #' @export #' @keywords internal #' @examples \dontrun{ -#' +#' #' # supposing that the data file gridcor.dat is in the current directory #' file <- "gridcor.dat" #' imp <- importGridcorInternal(file) -#' +#' #' # specifying a directory (arbitrary example directory) #' dir <- "/Users/markheckmann/data" #' imp <- importGridcorInternal(file, dir) -#' +#' #' # using a full path #' imp <- importGridcorInternal("/Users/markheckmann/data/gridcor.dat") -#' #' } #' -#' -importGridcorInternal <- function(file, dir=NULL) { - if (!is.null(dir)) - file <- paste(dir, file, sep="/", collapse="") +importGridcorInternal <- function(file, dir = NULL) { + if (!is.null(dir)) { + file <- paste(dir, file, sep = "/", collapse = "") + } l <- list() - # read meta info - datainfo <- scan(file = file, what = "raw", skip=1, # Read information line (2nd line) - nlines=1, quiet = TRUE) - l$datainfo <- joinString(datainfo) # join single items to long string - meta <- scan(file = file, what = "integer", - skip=0, nlines=1, quiet = TRUE) # Read number of elements and constructs - l$noConstructs <- as.numeric(meta)[1] # no of constructs - l$noElements <- as.numeric(meta)[2] # no of elements - l$minValue <- 1 # minimum value for Likert scale (min is 1) - l$maxValue <- as.numeric(meta)[3] # maximum value for Likert scale + # read meta info + datainfo <- scan( + file = file, what = "raw", skip = 1, # Read information line (2nd line) + nlines = 1, quiet = TRUE + ) + l$datainfo <- joinString(datainfo) # join single items to long string + meta <- scan( + file = file, what = "integer", + skip = 0, nlines = 1, quiet = TRUE + ) # Read number of elements and constructs + l$noConstructs <- as.numeric(meta)[1] # no of constructs + l$noElements <- as.numeric(meta)[2] # no of elements + l$minValue <- 1 # minimum value for Likert scale (min is 1) + l$maxValue <- as.numeric(meta)[3] # maximum value for Likert scale # read elements l$elements <- list() - for (i in 1:l$noElements){ - tmp <- scan(file = file, what = "character", skip=2+l$noConstructs+(i-1), - nlines=1, quiet = TRUE) # read elements line by line + for (i in 1:l$noElements) { + tmp <- scan( + file = file, what = "character", skip = 2 + l$noConstructs + (i - 1), + nlines = 1, quiet = TRUE + ) # read elements line by line l$elements[[i]] <- trimBlanksInString(joinString(tmp)) } - + # read constructs - l$constructs <- NA # poles come separately in gridcor files, no need to separate them + l$constructs <- NA # poles come separately in gridcor files, no need to separate them l$emergentPoles <- list() - for (i in 1:l$noConstructs){ - tmp <- scan(file = file, what = "character", skip=2+l$noConstructs+l$noElements+(i-1), - nlines=1, quiet = TRUE)# read construct line by line - l$emergentPoles[[i]] <- joinString(tmp) # save emergent pole + for (i in 1:l$noConstructs) { + tmp <- scan( + file = file, what = "character", skip = 2 + l$noConstructs + l$noElements + (i - 1), + nlines = 1, quiet = TRUE + ) # read construct line by line + l$emergentPoles[[i]] <- joinString(tmp) # save emergent pole } - + l$contrastPoles <- list() - for (i in 1:l$noConstructs){ - tmp <- scan(file = file, what = "character", skip=2+l$noConstructs+l$noElements+ - l$noConstructs+(i-1), nlines=1, quiet = TRUE) # read construct line by line - l$contrastPoles[[i]] <- joinString(tmp) # save contrast pole + for (i in 1:l$noConstructs) { + tmp <- scan(file = file, what = "character", skip = 2 + l$noConstructs + l$noElements + + l$noConstructs + (i - 1), nlines = 1, quiet = TRUE) # read construct line by line + l$contrastPoles[[i]] <- joinString(tmp) # save contrast pole } - + # read ratings l$ratings <- list() - for (i in 1:l$noConstructs){ - tmp <- scan(file = file, what = "character", # read ratings line by line - quiet = TRUE, skip=2 +(i-1), nlines=1) - l$ratings[[i]] <- strsplit(tmp, split="") + for (i in 1:l$noConstructs) { + tmp <- scan( + file = file, what = "character", # read ratings line by line + quiet = TRUE, skip = 2 + (i - 1), nlines = 1 + ) + l$ratings[[i]] <- strsplit(tmp, split = "") } l$ratings <- lapply(l$ratings, function(x) as.numeric(unlist(x))) l @@ -547,13 +581,13 @@ importGridcorInternal <- function(file, dir=NULL) { #' Import GRIDCOR data files. #' -#' Reads the file format that is used by the grid program +#' Reads the file format that is used by the grid program #' GRIDCOR (Feixas & Cornejo, 2002). #' -#' @param file filename including path if file is not in current working +#' @param file filename including path if file is not in current working #' directory. File can also be a complete URL. The fileformat #' is .dat. -#' @param dir alternative way to supply the directory where the file is located +#' @param dir alternative way to supply the directory where the file is located #' (default `NULL`). #' @return a single `repgrid` object in case one file and #' a list of `repgrid` objects in case multiple files are imported. @@ -562,8 +596,8 @@ importGridcorInternal <- function(file, dir=NULL) { #' #' Also note that both Gridcor and Gridstat data files do have the same suffix `.dat`. Make sure not to mix them up. #' @export -#' @references Feixas, G., & Cornejo, J. M. (2002). GRIDCOR: Correspondence Analysis -#' for Grid Data (version 4.0). Barcelona: Centro de Terapia Cognitiva. +#' @references Feixas, G., & Cornejo, J. M. (2002). GRIDCOR: Correspondence Analysis +#' for Grid Data (version 4.0). Barcelona: Centro de Terapia Cognitiva. #' Retrieved from . #' #' @seealso [importGridcor()], @@ -574,29 +608,28 @@ importGridcorInternal <- function(file, dir=NULL) { #' [importExcel()] #' #' @examples \dontrun{ -#' +#' #' # supposing that the data file gridcor.dat is in the current directory #' file <- "gridcor.dat" #' rg <- importGridcor(file) -#' +#' #' # specifying a directory (arbitrary example directory) #' dir <- "/Users/markheckmann/data" #' rg <- importGridcor(file, dir) -#' +#' #' # using a full path #' rg <- importGridcor("/Users/markheckmann/data/gridcor.dat") -#' #' } #' -#' -importGridcor <- function(file, dir=NULL) { - imps <- lapply(as.list(file), importGridcorInternal, # make import objects for each .txt file - dir=dir) - rgs <- lapply(imps, convertImportObjectToRepGridObject) # make repgrid object from import object +importGridcor <- function(file, dir = NULL) { + imps <- lapply(as.list(file), importGridcorInternal, # make import objects for each .txt file + dir = dir + ) + rgs <- lapply(imps, convertImportObjectToRepGridObject) # make repgrid object from import object if (length(file) == 1) { - return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted + return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted } else { - return(rgs) # return a list of repgrid objects + return(rgs) # return a list of repgrid objects } } @@ -612,95 +645,100 @@ importGridcor <- function(file, dir=NULL) { # the current mechanism will cause false assignments # #' Internal parser for Gridsuite data files -#' -#' @param file filename including path if file is not in current working +#' +#' @param file filename including path if file is not in current working #' directory. File can also be a complete URL. The fileformat #' is .dat. -#' @param dir alternative way to supply the directory where the file is located +#' @param dir alternative way to supply the directory where the file is located #' (default `NULL`). #' @note The developers of Gridsuite have proposed to use an XML scheme as -#' a standard exchange format for repertory grid data (Walter, -#' Bacher & Fromm, 2004). This approach is also embraced by the +#' a standard exchange format for repertory grid data (Walter, +#' Bacher & Fromm, 2004). This approach is also embraced by the #' `OpenRepGrid` package. #' #' @references #' -#' Walter, O. B., Bacher, A., & Fromm, M. (2004). A proposal -#' for a common data exchange format for repertory grid data. -#' *Journal of Constructivist Psychology, 17*(3), 247. +#' Walter, O. B., Bacher, A., & Fromm, M. (2004). A proposal +#' for a common data exchange format for repertory grid data. +#' *Journal of Constructivist Psychology, 17*(3), 247. #' doi:10.1080/10720530490447167 -#' @note TODO: The element and construct IDs are not used yet. Thus, -#' if the output should be in different order the current mechanism +#' @note TODO: The element and construct IDs are not used yet. Thus, +#' if the output should be in different order the current mechanism #' will cause false assignments. #' @export #' @keywords internal #' @examples \dontrun{ -#' +#' #' # supposing that the data file gridsuite.xml is in the current directory #' file <- "gridsuite.xml" #' imp <- importGridsuite(file) -#' +#' #' # specifying a directory (arbitrary example directory) #' dir <- "/Users/markheckmann/data" #' imp <- importGridsuite(file, dir) -#' +#' #' # using a full path #' imp <- importGridsuite("/Users/markheckmann/data/gridsuite.xml") -#' #' } #' -#' -importGridsuiteInternal <- function(file, dir=NULL){ - if(!is.null(dir)) - file <- paste(dir, file, sep="/", collapse="") - l <- list() - xmlFile <- xmlTreeParse(file) # parse XML file - root <- xmlRoot(xmlFile) # get root node - - ### header node - level.1.children <- xmlChildren(root) # get header node - level.1.header.children <- xmlChildren(level.1.children$header) # get header child nodes - l$topic <- xmlValue(level.1.header.children$topic) # topic - l$name <- xmlValue(level.1.header.children$name) # name - l$interviewer <- xmlValue(level.1.header.children$interviewer) # interviewer - l$date <- xmlValue(level.1.header.children$date) # date - l$comment <- xmlValue(level.1.header.children$comment) # comment - - ### elements node - level.1.elements.children <- xmlChildren(level.1.children$elements) # get elements node - tmp <- lapply(level.1.elements.children, xmlValue) # get element names (values) - l$elements <- tmp[names(tmp) %in% "element"] - l$noElements <- length(l$elements) # number of elements - - ### constructs node - level.1.constructs.children <- xmlChildren(level.1.children$constructs) - l$noConstructs <- length(level.1.constructs.children) # number of constructs - l$emergentPoles <- lapply(level.1.constructs.children, - function(x) xmlValue(xmlChildren(x)[[1]]) ) - l$contrastPoles <- lapply(level.1.constructs.children, - function(x) xmlValue(xmlChildren(x)[[2]]) ) - l$constructComments <- lapply(level.1.constructs.children, - function(x) xmlValue(xmlChildren(x)$comment)) - - ### ratings - ratingMeta <- xmlAttrs(level.1.children$ratings) - l$minValue <- as.numeric(ratingMeta["min"]) - l$maxValue <- as.numeric(ratingMeta["max"]) - l$scaleLevel <- ratingMeta["scale"] - - # get ratings for each e and c - # ratings are saved constructwise as a vector in a list - level.1.ratings.children <- xmlChildren(level.1.children$ratings) - ratings <- matrix(NA, ncol=l$noElements, nrow=l$noConstructs ) # matrix to save ratings - for(i in seq_along(level.1.ratings.children)){ - x <- level.1.ratings.children[[i]] - attrs <- xmlAttrs(x) - col <- as.numeric(attrs["ele_id"]) - row <- as.numeric(attrs["con_id"]) - ratings[row, col] <- as.numeric(xmlValue(x)) - } - l$ratings <- split(ratings, row(ratings)) # convert to list - l +importGridsuiteInternal <- function(file, dir = NULL) { + if (!is.null(dir)) { + file <- paste(dir, file, sep = "/", collapse = "") + } + l <- list() + xmlFile <- xmlTreeParse(file) # parse XML file + root <- xmlRoot(xmlFile) # get root node + + ### header node + level.1.children <- xmlChildren(root) # get header node + level.1.header.children <- xmlChildren(level.1.children$header) # get header child nodes + l$topic <- xmlValue(level.1.header.children$topic) # topic + l$name <- xmlValue(level.1.header.children$name) # name + l$interviewer <- xmlValue(level.1.header.children$interviewer) # interviewer + l$date <- xmlValue(level.1.header.children$date) # date + l$comment <- xmlValue(level.1.header.children$comment) # comment + + ### elements node + level.1.elements.children <- xmlChildren(level.1.children$elements) # get elements node + tmp <- lapply(level.1.elements.children, xmlValue) # get element names (values) + l$elements <- tmp[names(tmp) %in% "element"] + l$noElements <- length(l$elements) # number of elements + + ### constructs node + level.1.constructs.children <- xmlChildren(level.1.children$constructs) + l$noConstructs <- length(level.1.constructs.children) # number of constructs + l$emergentPoles <- lapply( + level.1.constructs.children, + function(x) xmlValue(xmlChildren(x)[[1]]) + ) + l$contrastPoles <- lapply( + level.1.constructs.children, + function(x) xmlValue(xmlChildren(x)[[2]]) + ) + l$constructComments <- lapply( + level.1.constructs.children, + function(x) xmlValue(xmlChildren(x)$comment) + ) + + ### ratings + ratingMeta <- xmlAttrs(level.1.children$ratings) + l$minValue <- as.numeric(ratingMeta["min"]) + l$maxValue <- as.numeric(ratingMeta["max"]) + l$scaleLevel <- ratingMeta["scale"] + + # get ratings for each e and c + # ratings are saved constructwise as a vector in a list + level.1.ratings.children <- xmlChildren(level.1.children$ratings) + ratings <- matrix(NA, ncol = l$noElements, nrow = l$noConstructs) # matrix to save ratings + for (i in seq_along(level.1.ratings.children)) { + x <- level.1.ratings.children[[i]] + attrs <- xmlAttrs(x) + col <- as.numeric(attrs["ele_id"]) + row <- as.numeric(attrs["con_id"]) + ratings[row, col] <- as.numeric(xmlValue(x)) + } + l$ratings <- split(ratings, row(ratings)) # convert to list + l } # file <- "/Users/markheckmann/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/gridsuite.xml" # file <- "/Users/unimitarbeiter/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/gridsuite.xml" @@ -709,16 +747,16 @@ importGridsuiteInternal <- function(file, dir=NULL){ #' Import Gridsuite data files. -#' -#' @param file Filename including path if file is not in current working +#' +#' @param file Filename including path if file is not in current working #' directory. File can also be a complete URL. The fileformat #' is .dat. -#' @param dir Alternative way to supply the directory where the file is located +#' @param dir Alternative way to supply the directory where the file is located #' (default `NULL`). #' @return A single `repgrid` object in case one file and #' a list of `repgrid` objects in case multiple files are imported. #' @note The developers of Gridsuite have proposed to use an XML scheme as a standard exchange format for repertory -#' grid data (Walter, Bacher & Fromm, 2004). +#' grid data (Walter, Bacher & Fromm, 2004). #' #' @references #' @@ -727,35 +765,34 @@ importGridsuiteInternal <- function(file, dir=NULL){ #' #' @note TODO: The element and construct IDs are not used yet. Thus, if the output should be in different order the #' current mechanism will cause false assignments. -#' +#' #' @export #' @seealso [importGridcor()], [importGridstat()], [importScivesco()], [importGridsuite()], [importTxt()], #' [importExcel()] #' #' @examples \dontrun{ -#' +#' #' # supposing that the data file gridsuite.xml is in the current directory #' file <- "gridsuite.xml" #' rg <- importGridsuite(file) -#' +#' #' # specifying a directory (arbitrary example directory) #' dir <- "/Users/markheckmann/data" #' rg <- importGridsuite(file, dir) -#' +#' #' # using a full path #' rg <- importGridsuite("/Users/markheckmann/data/gridsuite.xml") -#' #' } #' -#' -importGridsuite <- function(file, dir=NULL){ - imps <- lapply(as.list(file), importGridsuiteInternal, # make import objects for each .txt file - dir=dir) - rgs <- lapply(imps, convertImportObjectToRepGridObject) # make repgrid object from import object +importGridsuite <- function(file, dir = NULL) { + imps <- lapply(as.list(file), importGridsuiteInternal, # make import objects for each .txt file + dir = dir + ) + rgs <- lapply(imps, convertImportObjectToRepGridObject) # make repgrid object from import object if (length(file) == 1) { - return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted + return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted } else { - return(rgs) # return a list of repgrid objects + return(rgs) # return a list of repgrid objects } } @@ -764,13 +801,13 @@ importGridsuite <- function(file, dir=NULL){ # scivesco saves single grids in .scires files which have an XML structure. # Note: not all nodes are imported by importScivesco() -# Overview of file structure: +# Overview of file structure: # # -# +# # -# +# # # # @@ -800,111 +837,112 @@ importGridsuite <- function(file, dir=NULL){ # # due to Tetralemma field rating type # # -# ... +# ... -#file <- "/Users/markheckmann/Documents/Magic\ Briefcase/DA\ openRepgrid/openrepgrid/basic/data/scivesco/20100625_170217_01_MH.scires" -#file <- "/Users/markheckmann/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/scivesco.scires" -#file <- "/Users/unimitarbeiter/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/scivesco.scires" -#a <- importScivesco(file) +# file <- "/Users/markheckmann/Documents/Magic\ Briefcase/DA\ openRepgrid/openrepgrid/basic/data/scivesco/20100625_170217_01_MH.scires" +# file <- "/Users/markheckmann/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/scivesco.scires" +# file <- "/Users/unimitarbeiter/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/data/foreign/scivesco.scires" +# a <- importScivesco(file) #' Internal parser for sci:vesco files (suffix `scires`). -#' -#' @param file filename including path if file is not in current working +#' +#' @param file filename including path if file is not in current working #' directory. File can also be a complete URL. The fileformat #' is .dat. -#' @param dir alternative way to supply the directory where the file is located +#' @param dir alternative way to supply the directory where the file is located #' (default `NULL`). #' @return a list with extracted parameters. #' #' @note Sci:Vesco offers the options to rate the construct poles separately or using #' a bipolar scale. The separated rating is done using the "tetralemma" field. -#' The field is a bivariate plane on which each of the four (tetra) corners +#' The field is a bivariate plane on which each of the four (tetra) corners #' has a different meaning in terms of rating. Using this approach also allows ratings #' like: "both poles apply", "none of the poles apply" and all intermediate ratings #' can be chosen. This relaxes the bipolarity assumption often assumed in grid theory and #' allows for deviation from a strict bipolar rating if the constructs are not applied #' in a bipolar way. Using the tetralemma field for rating requires to analyze -#' each construct separately though. This means we get a double entry grid where the +#' each construct separately though. This means we get a double entry grid where the #' emergent and contrast pole ratings might not simply be a reflection of on another. -#' If a tetralemma field has been used for rating, `OpenRepGrid` offers the option +#' If a tetralemma field has been used for rating, `OpenRepGrid` offers the option #' to transform the scores into "normal" grid ratings (i.e. restricted to bipolarity) -#' by projecting the ratings from the bivariate tetralemma field onto the diagonal -#' of the tetralemma field and thus forcing a bipolar rating type. This option is +#' by projecting the ratings from the bivariate tetralemma field onto the diagonal +#' of the tetralemma field and thus forcing a bipolar rating type. This option is #' not recommended due to the fact that the conversion is susceptible to error #' when both ratings are near to zero. -#' @note TODO: The element IDs are not used yet. This might cause wrong assignments. +#' @note TODO: The element IDs are not used yet. This might cause wrong assignments. #' #' @export #' @keywords internal #' @examples \dontrun{ -#' +#' #' # supposing that the data file scivesco.scires is in the current directory #' file <- "scivesco.scires" #' imp <- importScivescoInternal(file) -#' +#' #' # specifying a directory (arbitrary example directory) #' dir <- "/Users/markheckmann/data" #' imp <- importScivescoInternal(file, dir) -#' +#' #' # using a full path #' imp <- importScivescoInternal("/Users/markheckmann/data/scivesco.scires") -#' #' } #' -#' -importScivescoInternal <- function(file, dir=NULL){ - if(!is.null(dir)) - file <- paste(dir, file, sep="/", collapse="") - xmlFile <- xmlTreeParse(file) # parse XML file - root <- xmlRoot(xmlFile) # get root node +importScivescoInternal <- function(file, dir = NULL) { + if (!is.null(dir)) { + file <- paste(dir, file, sep = "/", collapse = "") + } + xmlFile <- xmlTreeParse(file) # parse XML file + root <- xmlRoot(xmlFile) # get root node l <- list() ### interview node - level.1.children <- xmlChildren(root) # get interview top node + level.1.children <- xmlChildren(root) # get interview top node level.1.children$Interview - l$id <- xmlAttrs(level.1.children$Interview)["Id"] # interview ID + l$id <- xmlAttrs(level.1.children$Interview)["Id"] # interview ID l$date <- xmlAttrs(level.1.children$Interview)["StartDateTime"] # interview time node.2.interview <- xmlChildren(level.1.children$Interview) - l$interviewee <- xmlValue(node.2.interview$Expert) # name of expert/interviewee - l$interviewer <- xmlValue(node.2.interview$Interviewer) # name of interviewer - l$interviewNotes <- xmlValue(node.2.interview$Notes) # interview notes + l$interviewee <- xmlValue(node.2.interview$Expert) # name of expert/interviewee + l$interviewer <- xmlValue(node.2.interview$Interviewer) # name of interviewer + l$interviewNotes <- xmlValue(node.2.interview$Notes) # interview notes # InterviewSettingData node - level.3.InterviewSettingData <- + level.3.InterviewSettingData <- xmlChildren(node.2.interview$InterviewSettingData) l$interviewDescription <- xmlValue(level.3.InterviewSettingData$Description) l$ratingType <- xmlAttrs(level.3.InterviewSettingData$RatingType)["Default"] - level.4.Elements <- xmlChildren(level.3.InterviewSettingData$Elements) # get Elements child nodes - l$noElements <- - as.numeric(xmlAttrs(level.4.Elements$ElementsCollection)["Count"]) # get number of elements - level.5.Elements <- xmlChildren(level.4.Elements$ElementsCollection) # get number of elements + level.4.Elements <- xmlChildren(level.3.InterviewSettingData$Elements) # get Elements child nodes + l$noElements <- + as.numeric(xmlAttrs(level.4.Elements$ElementsCollection)["Count"]) # get number of elements + level.5.Elements <- xmlChildren(level.4.Elements$ElementsCollection) # get number of elements - getElementIdAndName <- function(x){ + getElementIdAndName <- function(x) { id <- xmlAttrs(x)["Id"] children <- xmlChildren(x) name <- xmlValue(children$Name) - c(id, name=name) + c(id, name = name) } l$elements <- lapply(level.5.Elements, getElementIdAndName) # InterviewResultTurnsCollection - level.3.InterviewResultTurnsCollection <- + level.3.InterviewResultTurnsCollection <- xmlChildren(node.2.interview$InterviewResultTurnsCollection) - getEmergentPole <- function(x) + getEmergentPole <- function(x) { xmlValue(xmlChildren(x)$Pole1) - getContrastPole <- function(x) + } + getContrastPole <- function(x) { xmlValue(xmlChildren(x)$Pole2) + } l$emergentPoles <- lapply(level.3.InterviewResultTurnsCollection, getEmergentPole) l$contrastPoles <- lapply(level.3.InterviewResultTurnsCollection, getContrastPole) - names(l$emergentPoles) <- rep("emergentPole", length(l$emergentPoles)) # cosmetic surgery to get nicer list names - names(l$contrastPoles) <- rep("contrastPole", length(l$contrastPoles)) # cosmetic surgery to get nicer list names + names(l$emergentPoles) <- rep("emergentPole", length(l$emergentPoles)) # cosmetic surgery to get nicer list names + names(l$contrastPoles) <- rep("contrastPole", length(l$contrastPoles)) # cosmetic surgery to get nicer list names # get ratings for both poles - # Here, for each construct/comparison two separate ratings are collected + # Here, for each construct/comparison two separate ratings are collected # resulting in two ratings list(ratings1 and ratings2). l$ratingsEmergent <- NA @@ -912,51 +950,59 @@ importScivescoInternal <- function(file, dir=NULL){ # The InterviewResultsReturnCollection has several InterviewResultTurn as # children. Each of these contains the ratings for one construct pair. - no.turns <- length(level.3.InterviewResultTurnsCollection) # no of construct pairs + no.turns <- length(level.3.InterviewResultTurnsCollection) # no of construct pairs # get ratings for pole1 and pole 2 from each construct pair. And return a # vector of ratings. # # x a InterviewResultTurn # digits number of digits to be rounded to - getRatingsFromTurn <- function(x, pole = 1, digits=2){ - if (pole == 1) - selectPole <- "RatingPole1" else - selectPole <- "RatingPole2" + getRatingsFromTurn <- function(x, pole = 1, digits = 2) { + if (pole == 1) { + selectPole <- "RatingPole1" + } else { + selectPole <- "RatingPole2" + } ratingsList <- xmlChildren(xmlChildren(x)[[selectPole]]) ratings <- lapply(ratingsList, xmlAttrs) - + ## old plyr code removed due to ::: in v0.1.9 - #df.ratings <- plyr:::list_to_dataframe(ratings)[-1] - #round(as.numeric(df.ratings$Value), digits) - + # df.ratings <- plyr:::list_to_dataframe(ratings)[-1] + # round(as.numeric(df.ratings$Value), digits) + # new code df.ratings.2 <- list_to_dataframe(ratings)[-1] names(df.ratings.2) <- "Value" round(as.numeric(as.character(df.ratings.2$Value)), digits) } l$ratings <- NA - l$ratings1 <- lapply(level.3.InterviewResultTurnsCollection, - getRatingsFromTurn, pole=1, digits=2) - l$ratings2 <- lapply(level.3.InterviewResultTurnsCollection, - getRatingsFromTurn, pole=2, digits=2) + l$ratings1 <- lapply(level.3.InterviewResultTurnsCollection, + getRatingsFromTurn, + pole = 1, digits = 2 + ) + l$ratings2 <- lapply(level.3.InterviewResultTurnsCollection, + getRatingsFromTurn, + pole = 2, digits = 2 + ) # project tetralemma ratings onto bipolar diagonal. Simply preserving # the relation bewteen the ratings linearly projected onto the diagonal # TODO: when tow values are near zero small deviations make big differences # maybe it is better to not to biploar reduction but only except grids # that have been elicited in a bipolar way! - projectToDiagonal <- function(pole1, pole2, res=1, SIMPLIFY=F){ + projectToDiagonal <- function(pole1, pole2, res = 1, SIMPLIFY = F) { rating.sum <- pole1 + pole2 - if (res==1) - list(pole1/rating.sum) else - list(pole2/rating.sum) + if (res == 1) { + list(pole1 / rating.sum) + } else { + list(pole2 / rating.sum) + } } - l$ratings <- mapply(projectToDiagonal, l$ratings1, l$ratings2) + l$ratings <- mapply(projectToDiagonal, l$ratings1, l$ratings2) # overwrite projection as not yet in good shape l$ratings <- l$ratings2 - + # getElementNameFromId <- function(id, l){ # x["ElementId"] # } @@ -967,14 +1013,14 @@ importScivescoInternal <- function(file, dir=NULL){ } -#' Convert the returned object from the sci:vesco import function into a `repgrid` +#' Convert the returned object from the sci:vesco import function into a `repgrid` #' object. -#' +#' #' @param x object returned from an import function. #' @return `repgrid` object. #' @keywords internal #' @export -convertScivescoImportObjectToRepGridObject <- function(import){ +convertScivescoImportObjectToRepGridObject <- function(import) { # structure of import object: # List of 16 # $ id : Named chr "dbd819e8-e8db-4acd-8fe2-355be1744929" @@ -998,22 +1044,25 @@ convertScivescoImportObjectToRepGridObject <- function(import){ # $ ratings :List of 5 # difference between tetralemma and bipolar rating grid - if (import$ratingType == "Tetralemma"){ # Tetralemma - stop("Tetralemma field ratings are not yet supported.\n", - "Currently only bipolar rating scales are supported.") - } else { # bipolar Rating scales - element.names <- lapply(import$elements, function(x) x[2]) # get Element names + if (import$ratingType == "Tetralemma") { # Tetralemma + stop( + "Tetralemma field ratings are not yet supported.\n", + "Currently only bipolar rating scales are supported." + ) + } else { # bipolar Rating scales + element.names <- lapply(import$elements, function(x) x[2]) # get Element names ratings <- round(t(sapply(import$ratings, I)), 1) * 10 # transform into by-row input for makeRepgrid -#browser() + # browser() args <- list( - name = unlist(element.names), # elements - l.name = unlist(import$emergentPoles), # left poles - r.name = unlist(import$contrastPoles), # right poles - scores = as.vector(t(ratings))) # ratings ... or t(ratings) ??? - # When sourced t is wrong, when build t is needed WTF??? - x <- makeRepgrid(args) # make repgrid - x <- setScale(x, 0, 1*10) # set scale range + name = unlist(element.names), # elements + l.name = unlist(import$emergentPoles), # left poles + r.name = unlist(import$contrastPoles), # right poles + scores = as.vector(t(ratings)) + ) # ratings ... or t(ratings) ??? + # When sourced t is wrong, when build t is needed WTF??? + x <- makeRepgrid(args) # make repgrid + x <- setScale(x, 0, 1 * 10) # set scale range x } x @@ -1021,11 +1070,11 @@ convertScivescoImportObjectToRepGridObject <- function(import){ #' Import sci:vesco data files. -#' -#' @param file Filename including path if file is not in current working +#' +#' @param file Filename including path if file is not in current working #' directory. File can also be a complete URL. The fileformat #' is .dat. -#' @param dir Alternative way to supply the directory where the file is located +#' @param dir Alternative way to supply the directory where the file is located #' (default `NULL`). #' @return A single `repgrid` object in case one file and #' a list of `repgrid` objects in case multiple files are imported. @@ -1047,35 +1096,35 @@ convertScivescoImportObjectToRepGridObject <- function(import){ #' @note TODO: For developers: The element IDs are not used yet. This might cause wrong assignments. #' #' @export -#' @references Menzel, F., Rosenberger, M., Buve, J. (2007). Emotionale, intuitive und +#' @references Menzel, F., Rosenberger, M., Buve, J. (2007). Emotionale, intuitive und #' rationale Konstrukte verstehen. *Personalfuehrung, 4*(7), 91-99. #' #' @seealso [importGridcor()], [importGridstat()], [importScivesco()], [importGridsuite()], [importTxt()], #' [importExcel()] #' #' @examples \dontrun{ -#' +#' #' # supposing that the data file scivesco.scires is in the current directory #' file <- "scivesco.scires" #' rg <- importScivesco(file) -#' +#' #' # specifying a directory (arbitrary example directory) #' dir <- "/Users/markheckmann/data" #' rg <- importScivesco(file, dir) -#' +#' #' # using a full path #' rg <- importScivesco("/Users/markheckmann/data/scivesco.scires") -#' #' } -importScivesco <- function(file, dir=NULL){ - imps <- lapply(as.list(file), importScivescoInternal, # make import objects for each .txt file - dir=dir) - rgs <- lapply(imps, convertScivescoImportObjectToRepGridObject) # make repgrid object from import object - +importScivesco <- function(file, dir = NULL) { + imps <- lapply(as.list(file), importScivescoInternal, # make import objects for each .txt file + dir = dir + ) + rgs <- lapply(imps, convertScivescoImportObjectToRepGridObject) # make repgrid object from import object + if (length(file) == 1) { - return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted + return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted } else { - return(rgs) # return a list of repgrid objects + return(rgs) # return a list of repgrid objects } } @@ -1123,17 +1172,17 @@ importScivesco <- function(file, dir=NULL){ #' #' Note that the maximum and minimum value has to be defined using the `min` and #' `max` arguments if no `RANGE` block is contained in the data file. -#' Otherwise the scaling range is inferred from the available data and a warning -#' is issued as the range may be erroneous. This may effect other functions that -#' depend on knowing the correct range and it is thus strongly recommended to +#' Otherwise the scaling range is inferred from the available data and a warning +#' is issued as the range may be erroneous. This may effect other functions that +#' depend on knowing the correct range and it is thus strongly recommended to #' set the scale range correctly. -#' +#' #' Question marks (?) in the ratings are treated as missing data. #' -#' @param file Filename including path if file is not in current working +#' @param file Filename including path if file is not in current working #' directory. File can also be a complete URL. The fileformat #' is `.txt`. -#' @param dir Alternative way to supply the directory where the file is located +#' @param dir Alternative way to supply the directory where the file is located #' (default `NULL`). #' @param min Optional argument (`numeric`, default `NULL`) #' for minimum rating value in grid. @@ -1144,103 +1193,110 @@ importScivesco <- function(file, dir=NULL){ #' @export #' @keywords internal #' @examples \dontrun{ -#' +#' #' # supposing that the data file sample.txt is in the current directory #' file <- "sample.txt" #' imp <- importTxtInternal(file) -#' +#' #' # specifying a directory (arbitrary example directory) #' dir <- "/Users/markheckmann/data" #' imp <- importTxtInternal(file, dir) -#' +#' #' # using a full path #' imp <- importTxtInternal("/Users/markheckmann/data/sample.txt") -#' #' } #' -importTxtInternal <- function(file, dir=NULL, min=NULL, max=NULL) -{ - if (!is.null(dir)) - file <- paste(dir, file, sep="/", collapse="") +importTxtInternal <- function(file, dir = NULL, min = NULL, max = NULL) { + if (!is.null(dir)) { + file <- paste(dir, file, sep = "/", collapse = "") + } - data <- readLines(file) # read txt file line by line - data <- gsub("\t", " ", data) # replace tabulators by simple blank - data <- data[str_trim(data) != ""] # remove all empty lines - - d <- str_trim(data) # remove blanks for better matching + data <- readLines(file) # read txt file line by line + data <- gsub("\t", " ", data) # replace tabulators by simple blank + data <- data[str_trim(data) != ""] # remove all empty lines + + d <- str_trim(data) # remove blanks for better matching line.elements <- which(d == "ELEMENTS") line.elements.end <- which(d == "END ELEMENTS") line.constructs <- which(d == "CONSTRUCTS") line.constructs.end <- which(d == "END CONSTRUCTS") - line.ratings <- which(d == "RATINGS") + line.ratings <- which(d == "RATINGS") line.ratings.end <- which(d == "END RATINGS") line.range <- which(d == "RANGE") - line.bipolar.implications <- which(d == "BIPOLAR IMPLICATIONS") + line.bipolar.implications <- which(d == "BIPOLAR IMPLICATIONS") line.bipolar.implications.end <- which(d == "END BIPOLAR IMPLICATIONS") - + l <- list() - + # read elements and trim blanks - l$elements <- as.list(data[(line.elements + 1):(line.elements.end-1)]) - l$elements <- lapply(l$elements, function(x) trimBlanksInString(x) ) - + l$elements <- as.list(data[(line.elements + 1):(line.elements.end - 1)]) + l$elements <- lapply(l$elements, function(x) trimBlanksInString(x)) + # read constructs and trim blanks - l$constructs <- as.list(data[(line.constructs + 1):(line.constructs.end-1)]) - l$constructs <- lapply(l$constructs, function(x) trimBlanksInString(x) ) + l$constructs <- as.list(data[(line.constructs + 1):(line.constructs.end - 1)]) + l$constructs <- lapply(l$constructs, function(x) trimBlanksInString(x)) tmp <- lapply(l$constructs, function(x) { - strsplit(x, ":")[[1]] # separate emergent and contrast pole by splitting at hyphen, colon or slash (see email from Richard) + strsplit(x, ":")[[1]] # separate emergent and contrast pole by splitting at hyphen, colon or slash (see email from Richard) }) - l$emergentPoles <- lapply(tmp, function(x) trimBlanksInString(x[1]) ) - l$contrastPoles <- lapply(tmp, function(x) trimBlanksInString(x[2]) ) - - # read ratings and convert to numeric - op <- options()$warn - options(warn=-1) - l$ratings <- as.list(data[(line.ratings + 1):(line.ratings.end-1)]) - l$ratings <- lapply(l$ratings, function(x){ - tmp <- trimBlanksInString(x) # trim blanks at beginning and end of string - tmp <- strsplit(tmp, "[ \t]+")[[1]] # split at one or more tabs or blanks - tmp <- gsub("[?]", "NA", tmp) # replace missing indicator (?) by "NA" + l$emergentPoles <- lapply(tmp, function(x) trimBlanksInString(x[1])) + l$contrastPoles <- lapply(tmp, function(x) trimBlanksInString(x[2])) + + # read ratings and convert to numeric + op <- options()$warn + options(warn = -1) + l$ratings <- as.list(data[(line.ratings + 1):(line.ratings.end - 1)]) + l$ratings <- lapply(l$ratings, function(x) { + tmp <- trimBlanksInString(x) # trim blanks at beginning and end of string + tmp <- strsplit(tmp, "[ \t]+")[[1]] # split at one or more tabs or blanks + tmp <- gsub("[?]", "NA", tmp) # replace missing indicator (?) by "NA" as.numeric(tmp) }) - options(warn=op) - + options(warn = op) + # read range if available - if (!identical(line.range, integer(0))){ - d <- data[line.range + 1] # get line with scale range data - tmp <- trimBlanksInString(d) # trim blanks at beginning and end of string - tmp <- strsplit(tmp, "[ \t]+")[[1]] # split at one or more tabs or blanks + if (!identical(line.range, integer(0))) { + d <- data[line.range + 1] # get line with scale range data + tmp <- trimBlanksInString(d) # trim blanks at beginning and end of string + tmp <- strsplit(tmp, "[ \t]+")[[1]] # split at one or more tabs or blanks range <- as.numeric(tmp) } else { - range <- c( min(unlist(l$ratings), na.rm=T), - max(unlist(l$ratings), na.rm=T)) - if(is.null(min) | is.null(max)){ - warning("the minimum and/or the maximum value of the rating scale have not been set explicitly.", - "The scale range was thus inferred by scanning the available ratings and may be wrong.", - "See ?importTxt for more information", call. = FALSE) + range <- c( + min(unlist(l$ratings), na.rm = T), + max(unlist(l$ratings), na.rm = T) + ) + if (is.null(min) | is.null(max)) { + warning("the minimum and/or the maximum value of the rating scale have not been set explicitly.", + "The scale range was thus inferred by scanning the available ratings and may be wrong.", + "See ?importTxt for more information", + call. = FALSE + ) } } - - l$noConstructs <- length(l$constructs) # no of constructs - l$noElements <- length(l$elements) # no of elements - l$minValue <- range[1] # minimum value for Likert scale - l$maxValue <- range[2] # maximum value for Likert scale - + + l$noConstructs <- length(l$constructs) # no of constructs + l$noElements <- length(l$elements) # no of elements + l$minValue <- range[1] # minimum value for Likert scale + l$maxValue <- range[2] # maximum value for Likert scale + if (is.null(min)) { l$minValue <- range[1] - } else l$minValue <- min + } else { + l$minValue <- min + } if (is.null(max)) { l$maxValue <- range[2] - } else l$maxValue <- max - - # read bipolar implications if available - if (!identical(line.bipolar.implications, integer(0)) & - !identical(line.bipolar.implications.end, integer(0))) { - l$bipolar.implications <- as.list(data[(line.bipolar.implications + 1):(line.bipolar.implications.end-1)]) - l$bipolar.implications <- lapply(l$bipolar.implications, function(x) trimBlanksInString(x) ) + } else { + l$maxValue <- max + } + + # read bipolar implications if available + if (!identical(line.bipolar.implications, integer(0)) & + !identical(line.bipolar.implications.end, integer(0))) { + l$bipolar.implications <- as.list(data[(line.bipolar.implications + 1):(line.bipolar.implications.end - 1)]) + l$bipolar.implications <- lapply(l$bipolar.implications, function(x) trimBlanksInString(x)) } - l + l } @@ -1289,10 +1345,10 @@ importTxtInternal <- function(file, dir=NULL, min=NULL, max=NULL) #' as the range may be erroneous. This may effect other functions that depend on knowing the correct range and it is #' thus strongly recommended to set the scale range correctly. #' -#' @param file A vector of filenames including the full path if file is not in current working +#' @param file A vector of filenames including the full path if file is not in current working #' directory. File can also be a complete URL. The file suffix #' has to be `.txt`. -#' @param dir Alternative way to supply the directory where the file is located +#' @param dir Alternative way to supply the directory where the file is located #' (default `NULL`). #' @param min Optional argument (`numeric`, default `NULL`) #' for minimum rating value in grid. @@ -1308,27 +1364,28 @@ importTxtInternal <- function(file, dir=NULL, min=NULL, max=NULL) #' # supposing that the data file sample.txt is in the current directory #' file <- "sample.txt" #' rg <- importTxt(file) -#' +#' #' # specifying a directory (arbitrary example directory) #' dir <- "/Users/markheckmann/data" #' rg <- importTxt(file, dir) -#' +#' #' # using a full path #' rg <- importTxt("/Users/markheckmann/data/sample.txt") -#' +#' #' # importing more than one .txt file via R code #' files <- c("sample.txt", "sample_2.txt") #' rg <- importTxt(files) #' } #' -importTxt <- function(file, dir=NULL, min=NULL, max=NULL){ - imps <- lapply(as.list(file), importTxtInternal, # make import objects for each .txt file - dir=dir, min=min, max=max) - rgs <- lapply(imps, convertImportObjectToRepGridObject) # make repgrid object from import object +importTxt <- function(file, dir = NULL, min = NULL, max = NULL) { + imps <- lapply(as.list(file), importTxtInternal, # make import objects for each .txt file + dir = dir, min = min, max = max + ) + rgs <- lapply(imps, convertImportObjectToRepGridObject) # make repgrid object from import object if (length(file) == 1) { - return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted + return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted } else { - return(rgs) # return a list of repgrid objects + return(rgs) # return a list of repgrid objects } } @@ -1338,79 +1395,83 @@ importTxt <- function(file, dir=NULL, min=NULL, max=NULL){ #' workhorse function (parser) for importExcel. -#' +#' #' @inheritParams importExcel #' @export #' @keywords internal -importExcelInternal <- function(file, dir=NULL, sheetIndex=1, - min=NULL, max=NULL) -{ - if (!is.null(dir)) - file <- paste(dir, file, sep="/", collapse="") - - # read in Excel file - x <- openxlsx::read.xlsx(file, sheet=sheetIndex, colNames=F) # read .xlxs or .xls file - - # remove NA lines when too many rows in Excel +importExcelInternal <- function(file, dir = NULL, sheetIndex = 1, + min = NULL, max = NULL) { + if (!is.null(dir)) { + file <- paste(dir, file, sep = "/", collapse = "") + } + + # read in Excel file + x <- openxlsx::read.xlsx(file, sheet = sheetIndex, colNames = F) # read .xlxs or .xls file + + # remove NA lines when too many rows in Excel na.rows <- apply(x, 1, function(x) all(is.na(unlist(x)))) x <- x[!na.rows, ] - - nc <- nrow(x) - 1 # number of constructs - ne <- ncol(x) - 2 # number of elements - + + nc <- nrow(x) - 1 # number of constructs + ne <- ncol(x) - 2 # number of elements + l <- list() - + # read elements - l$elements <- as.list(as.character((unlist(x[1, 2:(1+ne)])))) # list of element names - + l$elements <- as.list(as.character((unlist(x[1, 2:(1 + ne)])))) # list of element names + # read constructs and trim blanks l$emergentPoles <- as.list(as.character(x[2:(nc + 1), 1])) l$contrastPoles <- as.list(as.character(x[2:(nc + 1), ne + 2])) - + # read ratings and convert to numeric - ratings <- x[-1, c(-1, -(ne +2))] - ratings <- sapply(ratings, function(x) as.numeric(as.character(x))) # convert to numerics - l$ratings <- split(ratings, 1:nrow(ratings)) # convert df to list row-wise - #names(l$ratings) <- NULL - + ratings <- x[-1, c(-1, -(ne + 2))] + ratings <- sapply(ratings, function(x) as.numeric(as.character(x))) # convert to numerics + l$ratings <- split(ratings, 1:nrow(ratings)) # convert df to list row-wise + # names(l$ratings) <- NULL + # read range info if available - rmin <- as.numeric(as.vector(x[1,1])) + rmin <- as.numeric(as.vector(x[1, 1])) rmax <- as.numeric(as.vector(x[1, ne + 2])) - + # if not availabe infer range data and issue warning if (identical(rmin, numeric(0)) | identical(rmax, numeric(0))) { - warning("the minimum and/or the maximum value of the rating scale have not been set explicitly.", - "The scale range was thus inferred by scanning the available ratings and may be wrong.", - "See ?importExcel for more information", call. = FALSE) - rmin <- min(ratings, na.rm=TRUE) # infer rating range - rmax <- max(ratings, na.rm=TRUE) - } - - # overwrite scale range if given in arguments - if (!is.null(min)) + warning("the minimum and/or the maximum value of the rating scale have not been set explicitly.", + "The scale range was thus inferred by scanning the available ratings and may be wrong.", + "See ?importExcel for more information", + call. = FALSE + ) + rmin <- min(ratings, na.rm = TRUE) # infer rating range + rmax <- max(ratings, na.rm = TRUE) + } + + # overwrite scale range if given in arguments + if (!is.null(min)) { rmin <- min - if (!is.null(max)) + } + if (!is.null(max)) { rmax <- max - - l$noConstructs <- nc # no of constructs - l$noElements <- ne # no of elements - l$minValue <- rmin # minimum value for Likert scale - l$maxValue <- rmax # maximum value for Likert scale + } + + l$noConstructs <- nc # no of constructs + l$noElements <- ne # no of elements + l$minValue <- rmin # minimum value for Likert scale + l$maxValue <- rmax # maximum value for Likert scale l } #' Import grid data from an Excel file. -#' +#' #' You can define a grid using Microsoft Excel and by saving it as a -#' `.xlsx` file. The `.xlsx` file has to be in a specified fixed +#' `.xlsx` file. The `.xlsx` file has to be in a specified fixed #' format (see section Details). -#' +#' #' Excel file structure: The first row contains the minimum of the rating scale, #' the names of the elements and the maximum of the rating scale. Below every #' row contains the left construct pole, the ratings and the right construct #' pole. -#' +#' #' \tabular{lccccr}{ #' `1` \tab `E1` \tab `E2` \tab `E3` \tab `E4` \tab `5` \cr #' `left pole 1` \tab `1` \tab `5` \tab `3` \tab `4` \tab `right pole 1` \cr @@ -1425,9 +1486,9 @@ importExcelInternal <- function(file, dir=NULL, sheetIndex=1, #' erroneous. This may effect other functions that depend on knowing the correct #' range and it is thus strongly recommended to set the scale range correctly. #' -#' @param file A vector of filenames including the full path if file is not in current working -#' directory. The file suffix has to be `.xlsx` (used since Excel 2007). -#' @param dir Alternative way to supply the directory where the file is located +#' @param file A vector of filenames including the full path if file is not in current working +#' directory. The file suffix has to be `.xlsx` (used since Excel 2007). +#' @param dir Alternative way to supply the directory where the file is located #' (default `NULL`). #' @param sheetIndex The number of the Excel sheet that contains the grid data. #' @param min Optional argument (`numeric`, default `NULL`) @@ -1444,31 +1505,30 @@ importExcelInternal <- function(file, dir=NULL, sheetIndex=1, #' [importTxt()] #' #' @examples \dontrun{ -#' +#' #' # Open Excel file delivered along with the package #' file <- system.file("extdata", "grid_01.xlsx", package = "OpenRepGrid") #' rg <- importExcel(file) -#' +#' #' # To see the structure of the Excel file try to open it as follows. #' # Requires Excel to be installed. #' system2("open", file) -#' +#' #' # Import more than one Excel file -#' files <- system.file("extdata", c("grid_01.xlsx", "grid_02.xlsx") , package = "OpenRepGrid") +#' files <- system.file("extdata", c("grid_01.xlsx", "grid_02.xlsx"), package = "OpenRepGrid") #' rg <- importExcel(files) -#' #' } -#' -importExcel <- function(file, dir=NULL, sheetIndex=1, min=NULL, max=NULL) -{ - imps <- lapply(as.list(file), importExcelInternal, # make import objects for each .txt file - dir=dir, sheet=sheetIndex, - min=min, max=max) - rgs <- lapply(imps, convertImportObjectToRepGridObject) # make repgrid object from import object +#' +importExcel <- function(file, dir = NULL, sheetIndex = 1, min = NULL, max = NULL) { + imps <- lapply(as.list(file), importExcelInternal, # make import objects for each .txt file + dir = dir, sheet = sheetIndex, + min = min, max = max + ) + rgs <- lapply(imps, convertImportObjectToRepGridObject) # make repgrid object from import object if (length(file) == 1) { - return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted + return(rgs[[1]]) # return a single repgrid opbject if a single file is prompted } else { - return(rgs) # return a list of repgrid objects + return(rgs) # return a list of repgrid objects } } @@ -1477,20 +1537,20 @@ importExcel <- function(file, dir=NULL, sheetIndex=1, min=NULL, max=NULL) ############################# IMPORTING ################################### -guessDataSource <- function(file){ - ending <- tail(strsplit(file, "\\.")[[1]], n=1) # look at post fix - if (ending == "scires"){ +guessDataSource <- function(file) { + ending <- tail(strsplit(file, "\\.")[[1]], n = 1) # look at post fix + if (ending == "scires") { cat("Trying to load Sci:Vesco file: ", file) - importScivesco(file) - } else if (ending == "xml"){ + importScivesco(file) + } else if (ending == "xml") { cat("Trying to load Gridsuite file: ", file) - importGridsuite(file) - } else if (ending == "dat"){ + importGridsuite(file) + } else if (ending == "dat") { cat("Trying to load gridstat file: ", file) - importGridstat(file) + importGridstat(file) } else { stop("Please specify format by hand as", ending, "id not known") } } -#d <- guessDataSource(loadgrid()) +# d <- guessDataSource(loadgrid()) diff --git a/R/measures.r b/R/measures.r index 6b7bc331..54f543e7 100644 --- a/R/measures.r +++ b/R/measures.r @@ -1,4 +1,4 @@ -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # # # GRID INDEX MEASURES # # # @@ -6,12 +6,12 @@ # e.g. 'iBias' that stand for index followed by the an acronym # # of what is calculated. # # # -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # ___________________ ---- -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # HELPERS ---- -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// #' Print a square matrix in well readable format @@ -28,51 +28,54 @@ #' #' @export #' @keywords internal -print_square_matrix <- function(x, names = NA, trim = NA, - index = TRUE, width = NA, upper = TRUE) -{ - if (!is.matrix(x)) +print_square_matrix <- function(x, names = NA, trim = NA, + index = TRUE, width = NA, upper = TRUE) { + if (!is.matrix(x)) { stop("'x' muste be a matrix", call. = FALSE) - if (dim(x)[1] != dim(x)[2]) + } + if (dim(x)[1] != dim(x)[2]) { stop("'x' muste be a square matrix", call. = FALSE) - if (!is.null(names) && !is.na(names[1]) && length(names) != nrow(x)) + } + if (!is.null(names) && !is.na(names[1]) && length(names) != nrow(x)) { stop("length of 'names' must be equal to number of rows of 'x'", call. = FALSE) - if (!is.na(trim) && !trim >= 0) + } + if (!is.na(trim) && !trim >= 0) { stop("'trim' must be NA or >= 0", call. = FALSE) - + } + # set width of columns if (is.na(width)) { width <- max( - nchar(nrow(x)), # length of column index - nchar(max(x, na.rm = T)) # biggest value + nchar(nrow(x)), # length of column index + nchar(max(x, na.rm = T)) # biggest value ) } - + # trim names - if (!is.null(names) && !is.na(names[1]) && - !is.null(trim) && !is.na(trim[1])) { + if (!is.null(names) && !is.na(names[1]) && + !is.null(trim) && !is.na(trim[1])) { names <- substr(names, 1, trim) } - + # fill lower triangle with blanks of correct length if (upper) { x[lower.tri(x, diag = TRUE)] <- paste0(rep(" ", width), collapse = "") } - - # add index column for neater colnames + + # add index column for neater colnames if (index) { - x <- addIndexColumnToMatrix(x) + x <- addIndexColumnToMatrix(x) } else { colnames(x) <- seq_len(ncol(x)) - } - + } + # add names column in first position if (!is.na(names)[1]) { cnms <- c(" ", colnames(x)) x <- cbind(names, x) colnames(x) <- cnms } - + x <- as.data.frame(x, stringsAsFactors = FALSE) rownames(x) <- NULL print(x) @@ -101,20 +104,21 @@ print_square_matrix <- function(x, names = NA, trim = NA, #' #' @export #' @example inst/examples/example-matches.R -#' +#' matches <- function(x, deviation = 0, diag.na = TRUE) { stop_if_not_is_repgrid(x) - if (!is.numeric(deviation) || deviation < 0) + if (!is.numeric(deviation) || deviation < 0) { stop("'deviation' must be >= 0", call. = FALSE) + } R <- ratings(x, names = FALSE) - - # constructs + + # constructs M_c <- apply(t(R), 2, function(x) { - colSums(abs(x - t(R)) <= deviation) # matches per column + colSums(abs(x - t(R)) <= deviation) # matches per column }) # elements M_e <- apply(R, 2, function(x) { - colSums(abs(x - R) <= deviation) # matches per column + colSums(abs(x - R) <= deviation) # matches per column }) # set diagonal NA @@ -122,17 +126,17 @@ matches <- function(x, deviation = 0, diag.na = TRUE) { diag(M_c) <- NA diag(M_e) <- NA } - - # total number of C/E matches + + # total number of C/E matches total_constructs <- sum(M_c[upper.tri(M_c)]) total_elements <- sum(M_e[upper.tri(M_e)]) - + # maximal number of possible matches nc <- nrow(x) ne <- ncol(x) max_constructs <- unname(ne * nc * (nc - 1) / 2) max_elements <- unname(nc * ne * (ne - 1) / 2) - + l <- list( grid = x, deviation = deviation, @@ -160,15 +164,14 @@ matches <- function(x, deviation = 0, diag.na = TRUE) { #' @param upper Whether to only show the upper triangle (default `TRUE`). #' @export #' @keywords internal -print.org.matches <- function(x, output = "ICE", index = TRUE, - names = TRUE, trim = 50, upper = TRUE, width = NA, ...) -{ - l = x # renamed from 'l' to 'x' to match arg in print generic +print.org.matches <- function(x, output = "ICE", index = TRUE, + names = TRUE, trim = 50, upper = TRUE, width = NA, ...) { + l <- x # renamed from 'l' to 'x' to match arg in print generic output <- toupper(output) g <- l$grid if (names) { cnames <- constructs(g, collapse = TRUE) - enames <- elements(g) + enames <- elements(g) } else { cnames <- NA enames <- NA @@ -177,11 +180,11 @@ print.org.matches <- function(x, output = "ICE", index = TRUE, # matrices with no of matches M_c <- l$constructs M_e <- l$elements - + cat("\n##############") cat("\nRATING MATCHES") cat("\n##############\n") - + ## I = Info if (str_detect(output, "I")) { cat("\nMaximal rating difference to count as match: ", l$deviation) @@ -196,22 +199,26 @@ print.org.matches <- function(x, output = "ICE", index = TRUE, ## E = Elements if (str_detect(output, "E")) { cat(bold("\nELEMENTS\n\n")) - print_square_matrix(M_e, names = enames, index = index, - upper = upper, trim = trim, width = width) + print_square_matrix(M_e, + names = enames, index = index, + upper = upper, trim = trim, width = width + ) } ## C = Constructs if (str_detect(output, "C")) { cat(bold("\nCONSTRUCTS\n\n")) - print_square_matrix(M_c, names = cnames, index = index, - upper = upper, trim = trim, width = width) + print_square_matrix(M_c, + names = cnames, index = index, + upper = upper, trim = trim, width = width + ) } } # ___________________ ---- -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # SLATER MEASURES ---- -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// #' Calculate 'bias' of grid as defined by Slater (1977). @@ -226,21 +233,23 @@ print.org.matches <- function(x, output = "ICE", index = TRUE, #' @note STATUS: Working and checked against example in Slater, 1977, p. 87. #' @export #' @seealso [indexVariability()] -#' @examples -#' indexBias(boeker) -#' -indexBias <- function(x, min = NULL, max = NULL, digits=2) { +#' @examples +#' indexBias(boeker) +#' +indexBias <- function(x, min = NULL, max = NULL, digits = 2) { dat <- getRatingLayer(x) sc <- getScale(x) - if (is.null(min)) + if (is.null(min)) { min <- sc[1] - if (is.null(max)) + } + if (is.null(max)) { max <- sc[2] - p <- min + (max - min) / 2 # scale midpoint - q <- max - p # distance to scale limits - n <- nrow(dat) # number of rows (constructs) - row.means <- apply(dat, 1, mean, na.rm = TRUE) # means of construct rows - bias <- (sum((row.means - p)^2) / n)^.5 / q # calculation of bias + } + p <- min + (max - min) / 2 # scale midpoint + q <- max - p # distance to scale limits + n <- nrow(dat) # number of rows (constructs) + row.means <- apply(dat, 1, mean, na.rm = TRUE) # means of construct rows + bias <- (sum((row.means - p)^2) / n)^.5 / q # calculation of bias round(bias, digits) } @@ -258,37 +267,38 @@ indexBias <- function(x, min = NULL, max = NULL, digits=2) { #' @note STATUS: working and checked against example in Slater, 1977 , p.88. #' @export #' @seealso [indexBias()] -#' @examples -#' indexVariability(boeker) -#' -indexVariability <- function(x, min = NULL, max = NULL, digits = 2) -{ +#' @examples +#' indexVariability(boeker) +#' +indexVariability <- function(x, min = NULL, max = NULL, digits = 2) { dat <- getRatingLayer(x) sc <- getScale(x) - if (is.null(min)) + if (is.null(min)) { min <- sc[1] - if (is.null(max)) + } + if (is.null(max)) { max <- sc[2] - - D <- as.matrix(center(x)) # row centered grid matrix - W <- D %*% t(D) # co-variation Matrix W - V <- diag(W) # extract trace (construct variations) - V.tot <- sum(V, na.rm = TRUE) # total variation - - p <- min + (max - min) / 2 # scale midpoint - q <- max - p # distance to scale limits - n <- nrow(D) # number of rows (constructs) - m <- ncol(D) # number of columns (elements) - res <- (V.tot / (n * (m - 1)))^.5 / q # calculate variability + } + + D <- as.matrix(center(x)) # row centered grid matrix + W <- D %*% t(D) # co-variation Matrix W + V <- diag(W) # extract trace (construct variations) + V.tot <- sum(V, na.rm = TRUE) # total variation + + p <- min + (max - min) / 2 # scale midpoint + q <- max - p # distance to scale limits + n <- nrow(D) # number of rows (constructs) + m <- ncol(D) # number of columns (elements) + res <- (V.tot / (n * (m - 1)))^.5 / q # calculate variability round(res, digits) } # . ---- # ___________________ ---- -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # MISC ---- -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// #' Percentage of Variance Accounted for by the First Factor (PVAFF) @@ -313,39 +323,41 @@ indexVariability <- function(x, min = NULL, max = NULL, digits = 2) #' #' James, R. E. (1954). *Identification in terms of personal constructs* (Unpublished doctoral thesis). Ohio State #' University, Columbus, OH. -#' +#' #' @export #' @examples #' -#' indexPvaff(bell2010) -#' +#' indexPvaff(bell2010) +#' indexPvaff <- function(x, method = 1) { - message("Note: As of v0.1.14 PVAFF is derived using PCA of the construct centered ratings by default.", - "Before that the construct correlation matrix was used (see method=2).\n\n") - if (!inherits(x, "repgrid")) + message( + "Note: As of v0.1.14 PVAFF is derived using PCA of the construct centered ratings by default.", + "Before that the construct correlation matrix was used (see method=2).\n\n" + ) + if (!inherits(x, "repgrid")) { stop("Object must be of class 'repgrid'") - + } + if (method == 1) { - r <- ratings(x) + r <- ratings(x) p <- stats::prcomp(t(r), center = TRUE, scale. = FALSE) pvaff <- (p$sdev^2 / sum(p$sdev^2))[1] - } else if (method == 2) { cr <- constructCor(x) sv <- svd(cr)$d - pvaff <- sv[1] ^ 2 / sum(sv ^ 2) + pvaff <- sv[1]^2 / sum(sv^2) } else { stop("'method' must be 1 or 2.", call. = FALSE) } - + return(pvaff) } # Print method for class indexPvaff. -# +# # @param x Object of class indexPvaff. -# @param digits Numeric. Number of digits to round to (default is +# @param digits Numeric. Number of digits to round to (default is # \code{2}). # @param ... Not evaluated. # @export @@ -384,14 +396,14 @@ indexPvaff <- function(x, method = 1) { #' @example inst/examples/example-indexBieri.R #' @export #' -#' +#' indexBieri <- function(x, deviation = 0) { stop_if_not_is_repgrid(x) - + m <- matches(x, deviation = deviation) n_matches <- m$total_constructs - n_matches_max <- m$max_constructs - + n_matches_max <- m$max_constructs + l <- list( grid = x, deviation = deviation, @@ -413,19 +425,19 @@ indexBieri <- function(x, deviation = 0) { #' @param digits Number of digits to display. #' @export #' @keywords internal -#' +#' print.indexBieri <- function(x, output = "I", digits = 3, ...) { cat("\n######################") cat("\nBIERI COMPLEXITY INDEX") cat("\n######################\n") - + M_c <- x$constructs cnames <- constructs(x$grid, collapse = T) index <- TRUE upper <- TRUE width <- NA trim <- 50 - + ## I = Information if (str_detect(output, "I")) { cat("\nBieri:", round(x$bieri, digits)) @@ -438,10 +450,11 @@ print.indexBieri <- function(x, output = "I", digits = 3, ...) { ## C = Constructs if (str_detect(output, "C")) { cat(bold("\nMATCHES BETWEEN CONSTRUCTS\n\n")) - print_square_matrix(M_c, names = cnames, index = index, - upper = upper, trim = trim, width = width) + print_square_matrix(M_c, + names = cnames, index = index, + upper = upper, trim = trim, width = width + ) } - } @@ -478,39 +491,45 @@ print.indexBieri <- function(x, output = "I", digits = 3, ...) { #' #' @example inst/examples/example-indexDilemmatic.R #' @export -#' +#' indexDilemmatic <- function(x, ideal, deviation = 0, warn = TRUE) { - if (!is.repgrid(x)) + if (!is.repgrid(x)) { stop("'x' must be 'repgrid' object", call. = FALSE) + } ne <- ncol(x) - if (ideal < 1 || ideal > ncol(x)) + if (ideal < 1 || ideal > ncol(x)) { stop("'ideal' must be in the range from 1 to ", ne, call. = FALSE) - + } + # warn if uneven number of rating options n_options <- diff(getScale(x)) + 1 if (n_options %% 2 == 0 && warn) { warning("The rating scale has an even number of options (", n_options, "). ", - "Dilemmatic constructs usually require an uneven rating scale length (see details)", call. = FALSE) + "Dilemmatic constructs usually require an uneven rating scale length (see details)", + call. = FALSE + ) } # warn if uneven number of rating options if (n_options >= 16 && deviation == 0 && warn) { warning("The rating scale is quite long (", n_options, "). ", - "You may want to consider allowing deviations from the midpoint (see details)", call. = FALSE) + "You may want to consider allowing deviations from the midpoint (see details)", + call. = FALSE + ) } - + cnames <- constructs(x, collapse = TRUE) R <- ratings(x) r_ideal <- R[, ideal] m <- midpoint(x) sc <- getScale(x) - lower <- m - deviation + lower <- m - deviation upper <- m + deviation i_low <- r_ideal >= lower i_high <- r_ideal <= upper i_dilemmatic <- i_low & i_high - n_dilemmatic <- sum(i_dilemmatic) + n_dilemmatic <- sum(i_dilemmatic) midpoint_range <- paste0("[", upper, ", ", lower, "]") - + df_dilemmatic <- data.frame( Construct = constructs(x, collapse = TRUE), Ideal = unname(r_ideal), @@ -518,7 +537,7 @@ indexDilemmatic <- function(x, ideal, deviation = 0, warn = TRUE) { Dilemmatic = i_dilemmatic ) rownames(df_dilemmatic) <- NULL - + l <- list( ideal = elements(x)[ideal], n_constructs = nrow(x), @@ -547,14 +566,13 @@ indexDilemmatic <- function(x, ideal, deviation = 0, warn = TRUE) { #' @export #' @method print indexDilemmatic #' @keywords internal -print.indexDilemmatic <- function(x, output = "SD", ...) -{ +print.indexDilemmatic <- function(x, output = "SD", ...) { output <- toupper(output) - + cat("\n#####################") cat("\nDilemmatic Constructs") cat("\n#####################\n") - + ## I = Info if (str_detect(output, "S")) { cat(bold("\nSUMMARY\n")) @@ -564,16 +582,20 @@ print.indexDilemmatic <- function(x, output = "SD", ...) cat("\nDilemmatic: Constructs with ideal ratings in the interval", x$midpoint_range) cat("\n") cat("\nNo. of dilemmatic constructs:", x$n_dilemmatic) - cat("\nPercent dilemmatic constructs: ", scales::percent(x$perc_dilemmatic, .1), - " (", x$n_dilemmatic, "/", x$n_constructs, ")", sep = "") + cat("\nPercent dilemmatic constructs: ", scales::percent(x$perc_dilemmatic, .1), + " (", x$n_dilemmatic, "/", x$n_constructs, ")", + sep = "" + ) } - + ## C = Constructs if (str_detect(output, "D")) { cat("\n") cat(bold("\nDETAILS\n\n")) if (x$n_dilemmatic > 0) { - x$summary %>% dplyr::filter(Dilemmatic) %>% print + x$summary %>% + dplyr::filter(Dilemmatic) %>% + print() } else { cat(" No dilemmatic constructs found.\n") } @@ -617,50 +639,53 @@ print.indexDilemmatic <- function(x, output = "SD", ...) #' science*, 106, 1230-49. #' @examples #' -#' indexIntensity(bell2010) -#' indexIntensity(bell2010, trim = NA) +#' indexIntensity(bell2010) +#' indexIntensity(bell2010, trim = NA) #' -#' # using Cohen's rc for element correlations -#' indexIntensity(bell2010, rc = TRUE) +#' # using Cohen's rc for element correlations +#' indexIntensity(bell2010, rc = TRUE) #' -#' # save output -#' x <- indexIntensity(bell2010) -#' x +#' # save output +#' x <- indexIntensity(bell2010) +#' x #' -#' # printing options -#' print(x, digits=4) +#' # printing options +#' print(x, digits = 4) +#' +#' # accessing the objects' content +#' x$c.int +#' x$e.int +#' x$c.int.mean +#' x$e.int.mean +#' x$total.int #' -#' # accessing the objects' content -#' x$c.int -#' x$e.int -#' x$c.int.mean -#' x$e.int.mean -#' x$total.int -#' indexIntensity <- function(x, rc = FALSE, trim = 30) { - if (!is.repgrid(x)) + if (!is.repgrid(x)) { stop("'x' must be 'repgrid' object", call. = FALSE) - + } + cr <- constructCor(x, trim = trim) nc <- getNoOfConstructs(x) - diag(cr) <- 0 # out zeros in diagonal (won't have an effect) - c.int <- apply(cr^2, 2, function(x) sum(x) / (nc - 1)) # sum of squared correlations / nc -1 - - er <- elementCor(x, rc = rc, trim = trim) + diag(cr) <- 0 # out zeros in diagonal (won't have an effect) + c.int <- apply(cr^2, 2, function(x) sum(x) / (nc - 1)) # sum of squared correlations / nc -1 + + er <- elementCor(x, rc = rc, trim = trim) ne <- getNoOfElements(x) - diag(er) <- 0 # out zeros in diagonal (won't have an effect) - e.int <- apply(er^2, 2, function(x) sum(x) / (ne - 1)) # sum of squared correlations / (ne - 1) - - c.int.mean <- mean(c.int, na.rm = TRUE) # mean of construct intensity scores - e.int.mean <- mean(e.int, na.rm = TRUE) # mean of element intensity scores - + diag(er) <- 0 # out zeros in diagonal (won't have an effect) + e.int <- apply(er^2, 2, function(x) sum(x) / (ne - 1)) # sum of squared correlations / (ne - 1) + + c.int.mean <- mean(c.int, na.rm = TRUE) # mean of construct intensity scores + e.int.mean <- mean(e.int, na.rm = TRUE) # mean of element intensity scores + total.int <- mean(c(c.int, e.int, na.rm = TRUE)) - - res <- list(c.int = c.int, - e.int = e.int, - c.int.mean = c.int.mean, - e.int.mean = e.int.mean, - total.int = total.int) + + res <- list( + c.int = c.int, + e.int = e.int, + c.int.mean = c.int.mean, + e.int.mean = e.int.mean, + total.int = total.int + ) class(res) <- "indexIntensity" res } @@ -675,19 +700,19 @@ indexIntensity <- function(x, rc = FALSE, trim = 30) { #' @export #' @method print indexIntensity #' @keywords internal -#' +#' print.indexIntensity <- function(x, digits = 2, output = "TCE", ...) { output <- toupper(output) - + cat("\n################") cat("\nIntensity index") cat("\n################") - + ## T = Total if (str_detect(output, "T")) { cat("\n\nTotal intensity:", round(x$total.int, digits), "\n") } - + ## C = Constructs if (str_detect(output, "C")) { cat("\n\nAverage intensity of constructs:", round(x$c.int.mean, digits), "\n") @@ -696,7 +721,7 @@ print.indexIntensity <- function(x, digits = 2, output = "TCE", ...) { rownames(df.c.int) <- paste(seq_along(x$c.int), names(x$c.int)) print(round(df.c.int, digits)) } - + ## E = Elements if (str_detect(output, "E")) { cat("\n\nAverage intensity of elements:", round(x$e.int.mean, digits), "\n") @@ -726,23 +751,23 @@ print.indexIntensity <- function(x, digits = 2, output = "TCE", ...) { #' #' @example inst/examples/example-indexPolarization.R #' @export -#' -indexPolarization <- function(x, deviation = 0) -{ - if (!is.repgrid(x)) +#' +indexPolarization <- function(x, deviation = 0) { + if (!is.repgrid(x)) { stop("'x' must be 'repgrid' object", call. = FALSE) - + } + R <- ratings(x) sc <- getScale(x) - lower <- sc["min"] + deviation + lower <- sc["min"] + deviation upper <- sc["max"] - deviation i_low <- R <= lower i_high <- R >= upper ii <- i_low | i_high K <- R - K[,] <- ii # indicator matrix 0/1 + K[, ] <- ii # indicator matrix 0/1 R[!ii] <- NA - + l <- list( scale = sc, lower = lower, @@ -782,43 +807,51 @@ indexPolarization <- function(x, deviation = 0) #' print.indexPolarization <- function(x, output = "ITCE", ...) { output <- toupper(output) - + cat("\n##################") cat("\nPolarization index") cat("\n##################\n") - + ## I = Info if (str_detect(output, "I")) { - cat("\nThe grid is rated on a scale from", - x$scale["min"], "(left pole) to", x$scale["max"], "(right pole)") + cat( + "\nThe grid is rated on a scale from", + x$scale["min"], "(left pole) to", x$scale["max"], "(right pole)" + ) cat("\nExtreme ratings are ratings <=", x$lower, "or >=", x$upper) } - + ## T = Total if (str_detect(output, "T")) { cat("\n\n") cat(bold("\nPOLARIZATION OVERALL\n\n")) - x$polarization_total %>% dplyr::mutate( - Polarization = scales::percent(Polarization, .1) - ) %>% print + x$polarization_total %>% + dplyr::mutate( + Polarization = scales::percent(Polarization, .1) + ) %>% + print() } - + ## C = Constructs if (str_detect(output, "C")) { cat("\n") cat(bold("\nPOLARIZATION BY CONSTRUCT\n\n")) - x$polarization_constructs %>% dplyr::mutate( - Polarization = scales::percent(Polarization, .1) - ) %>% print + x$polarization_constructs %>% + dplyr::mutate( + Polarization = scales::percent(Polarization, .1) + ) %>% + print() } - + ## E = Elements if (str_detect(output, "E")) { cat("\n") cat(bold("\nPOLARIZATION BY ELEMENT\n\n")) - x$polarization_elements %>% dplyr::mutate( - Polarization = scales::percent(Polarization, .1) - ) %>% print + x$polarization_elements %>% + dplyr::mutate( + Polarization = scales::percent(Polarization, .1) + ) %>% + print() } } @@ -855,41 +888,51 @@ print.indexPolarization <- function(x, output = "ITCE", ...) { #' @export #' @example inst/examples/example-indexSelfConstruction.R #' -indexSelfConstruction <- function(x, self, ideal, others = c(-self, -ideal), - method = "euclidean", p = 2, normalize = TRUE, +indexSelfConstruction <- function(x, self, ideal, others = c(-self, -ideal), + method = "euclidean", p = 2, normalize = TRUE, round = FALSE) { # sanity/arg checks - if (!is.repgrid(x)) + if (!is.repgrid(x)) { stop("'x' must be a repgrid object", call. = FALSE) + } nc <- ncol(x) - if (!is.numeric(self) || !length(self) == 1 || !(self >= 1 && self <= nc)) + if (!is.numeric(self) || !length(self) == 1 || !(self >= 1 && self <= nc)) { stop("'self' must be ONE numeric value in the range from 1 to ", nc, call. = FALSE) - if (!is.numeric(ideal) || !length(ideal) == 1 || !(ideal >= 1 && ideal <= nc)) + } + if (!is.numeric(ideal) || !length(ideal) == 1 || !(ideal >= 1 && ideal <= nc)) { stop("'ideal' must be ONE numeric value in the range from 1 to ", nc, call. = FALSE) - if (!is.numeric(others) || !length(others) >= 1) + } + if (!is.numeric(others) || !length(others) >= 1) { stop("'others' must be a numeric vector with at least one entry", call. = FALSE) - if (!all(abs(others) >= 1) && all(abs(others) <= nc)) + } + if (!all(abs(others) >= 1) && all(abs(others) <= nc)) { stop("indexes indicating 'others' must range between 1 and ", nc, call. = FALSE) - if (any(others < 0) && any(others > 0)) + } + if (any(others < 0) && any(others > 0)) { stop("It is not allowed to mix positive and negative indexes", call. = FALSE) - if ( sum(duplicated(abs(others))) > 0) + } + if (sum(duplicated(abs(others))) > 0) { stop("duplicated indexes ore not allowed in 'others'", call. = FALSE) - + } + # treat negative indexes - if (all(others < 0)) + if (all(others < 0)) { others <- setdiff(1L:nc, abs(others)) - + } + # warnings for potentially wring input - if (self %in% others) + if (self %in% others) { warning("'self' is also contained in 'others'", call. = FALSE) - if (ideal %in% others) + } + if (ideal %in% others) { warning("'ideal' is also contained in 'others'", call. = FALSE) - + } + # build a new 'others' element as average rating of all others elements digits <- ifelse(round, 0, Inf) x <- addAvgElement(x, name = "others", i = others, digits = digits) i_others <- ncol(x) - + # Select method and get measures distances <- c("euclidean", "manhattan", "maximum", "canberra", "binary", "minkowski") correlations <- c("pearson", "kendall", "spearman") @@ -899,19 +942,19 @@ indexSelfConstruction <- function(x, self, ideal, others = c(-self, -ideal), if (method %in% distances) { method_type <- "distance" S <- distance(x, along = 2, dmethod = method, p = p, normalize = normalize) - } + } if (method %in% c("pearson", "kendall", "spearman")) { method_type <- "correlation" S <- elementCor(x, rc = TRUE, method = method) } - + # extract relevant measures s_self_ideal <- S[self, ideal] s_self_others <- S[self, i_others] s_ideal_others <- S[ideal, i_others] - + enames <- elements(x) - + # return indexSelfConstruction object l <- list( grid = x[, c(self, ideal, i_others)], @@ -934,9 +977,8 @@ indexSelfConstruction <- function(x, self, ideal, others = c(-self, -ideal), #' Print method for indexSelfConstruction #' @export #' @keywords internal -#' -print.indexSelfConstruction <- function(x, digits = 2, ...) -{ +#' +print.indexSelfConstruction <- function(x, digits = 2, ...) { w <- options()$width l <- x cat("=================") @@ -949,13 +991,17 @@ print.indexSelfConstruction <- function(x, digits = 2, ...) if (l$method_type == "correlation") { cat(crayon::blue( strwrap("Note: All correlations use Cohen's rc version which is invariant to construct reflections", - indent = 2, prefix = "\n", exdent = 8))) + indent = 2, prefix = "\n", exdent = 8 + ) + )) } cat("\n") - cat("\nCOMPARISONS\n", - "\n * Self - Ideal: ", round(l$self_ideal, digits), - "\n * Self - Others: ", round(l$self_others, digits), - "\n * Ideal - Others: ", round(l$ideal_others, digits)) + cat( + "\nCOMPARISONS\n", + "\n * Self - Ideal: ", round(l$self_ideal, digits), + "\n * Self - Others: ", round(l$self_others, digits), + "\n * Ideal - Others: ", round(l$ideal_others, digits) + ) cat("\n") cat("\nELEMENTS\n") cat("\n * self:", l$self_element) @@ -966,12 +1012,12 @@ print.indexSelfConstruction <- function(x, digits = 2, ...) # # Alternative using cli package. I do not like the look -# print.indexSelfConstruction <- function(x, digits = 2, ...) +# print.indexSelfConstruction <- function(x, digits = 2, ...) # { # w <- options()$width # l <- x # cli_h1("COGNITIVE PROFILE") -# +# # cli_h3("MEASURE") # cat_line() # cat_line(" ", l$method, " ", l$method_type) @@ -982,7 +1028,7 @@ print.indexSelfConstruction <- function(x, digits = 2, ...) # } # cli_h3("COMPARISONS") # cat_line() -# comp <- +# comp <- # c(paste("Self - Ideal: ", round(l$self_ideal, digits)), # paste("Self - Others: ", round(l$self_others, digits)), # paste("Ideal - Others: ", round(l$ideal_others, digits)) @@ -990,21 +1036,21 @@ print.indexSelfConstruction <- function(x, digits = 2, ...) # cat_bullet(comp) # cli_h3("ELEMENTS") # cat_line() -# elems <- +# elems <- # c(paste("self: ", l$self_element), # paste("ideal: ", l$ideal_element), # paste("others:", strwrap(paste(l$other_elements, collapse = ", "), width = w - 12, exdent = 12, prefix = "\n", initial = ""), collapse = " ") # ) -# +# # cat_bullet(elems) # } # . ---------- # ___________________ ---- -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # CONFLICT MEASURES ---- -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # __ Misc ---------------------------------- @@ -1017,20 +1063,24 @@ print.indexSelfConstruction <- function(x, digits = 2, ...) #' @export #' @method print indexConflict1 #' @keywords internal -#' -print.indexConflict1 <- function(x, digits=1, ...) { +#' +print.indexConflict1 <- function(x, digits = 1, ...) { cat("\n################################") cat("\nConflicts based on correlations") - cat("\n################################") + cat("\n################################") cat("\n\nAs devised by Slade & Sheehan (1979)") - + cat("\n\nTotal number of triads:", x$total) - cat("\nNumber of imbalanced triads:",x$imbalanced) - - cat("\n\nProportion of balanced triads:", - round(x$prop.balanced * 100, digits = digits), "%") - cat("\nProportion of imbalanced triads:", - round(x$prop.imbalanced * 100, digits = digits), "%") + cat("\nNumber of imbalanced triads:", x$imbalanced) + + cat( + "\n\nProportion of balanced triads:", + round(x$prop.balanced * 100, digits = digits), "%" + ) + cat( + "\nProportion of imbalanced triads:", + round(x$prop.imbalanced * 100, digits = digits), "%" + ) } @@ -1059,7 +1109,7 @@ print.indexConflict1 <- function(x, digits=1, ...) { #' @title Conflict measure for grids (Slade & Sheehan, 1979) based on correlations. #' @param x `repgrid` object. #' @return A list with the following elements: -#' +#' #' - `total`: Total number of triads #' - `imbalanced`: Number of imbalanced triads #' - `prop.balanced`: Proportion of balanced triads @@ -1079,38 +1129,43 @@ print.indexConflict1 <- function(x, digits=1, ...) { #' #' Winter, D. A. (1982). Construct relationships, psychological disorder and therapeutic change. *The British Journal #' of Medical Psychology, 55* (Pt 3), 257-269. -#' +#' #' @export #' @seealso [indexConflict2()] for an improved version of this measure; see [indexConflict3()] for a measure based on distances. -#' @examples -#' -#' indexConflict1(feixas2004) -#' indexConflict1(boeker) +#' @examples +#' +#' indexConflict1(feixas2004) +#' indexConflict1(boeker) #' indexConflict1 <- function(x) { - if (!inherits(x, "repgrid")) + if (!inherits(x, "repgrid")) { stop("Object must be of class 'repgrid'") - - r <- constructCor(x) # construct correlation matrix + } + + r <- constructCor(x) # construct correlation matrix z <- fisherz(r) - nc <- getNoOfConstructs(x) # number of constructs - comb <- t(combn(nc, 3)) # all possible correlation triads - balanced <- rep(NA, nrow(comb)) # set up result vector - + nc <- getNoOfConstructs(x) # number of constructs + comb <- t(combn(nc, 3)) # all possible correlation triads + balanced <- rep(NA, nrow(comb)) # set up result vector + for (i in 1:nrow(comb)) { - z.triad <- z[t(combn(comb[i, ], 2))] # correlations of triad + z.triad <- z[t(combn(comb[i, ], 2))] # correlations of triad z.prod <- prod(z.triad) - if (sign(z.prod) > 0) # triad is imbalanced if product of correlations is negative - balanced[i] <- TRUE else - balanced[i] <- FALSE - } - prop.balanced <- sum(balanced) / length(balanced) # proportion of - prop.imbalanced <- 1 - prop.balanced # proportion of - - res <- list(total = length(balanced), - imbalanced = sum(!balanced), - prop.balanced = prop.balanced, - prop.imbalanced = prop.imbalanced) + if (sign(z.prod) > 0) { # triad is imbalanced if product of correlations is negative + balanced[i] <- TRUE + } else { + balanced[i] <- FALSE + } + } + prop.balanced <- sum(balanced) / length(balanced) # proportion of + prop.imbalanced <- 1 - prop.balanced # proportion of + + res <- list( + total = length(balanced), + imbalanced = sum(!balanced), + prop.balanced = prop.balanced, + prop.imbalanced = prop.imbalanced + ) class(res) <- "indexConflict1" res } @@ -1124,20 +1179,20 @@ indexConflict1 <- function(x) { #' As a result, small correlations that are psychologically meaningless are considered accordingly. Also, correlations #' with a small magnitude, i. e. near zero, which may be positive or negative due to chance alone will no longer #' distort the measure (Bassler et al., 1992). -#' +#' #' Description of the balance / imbalance assessment: #' #' 1. Order correlations of the triad by absolute magnitude, so that \eqn{ r_{max} > r_{mdn} > r_{min} }{r_max > r_mdn > r_min}. #' 2. Apply Fisher's Z-transformation and division by 3 to yield values between 1 and -1 (\eqn{ Z_{max} > Z_{mdn} > Z_{min} }{Z_max > Z_mdn > Z_min}). #' 3. Check whether the triad is balanced by assessing if the following relation holds: -#' -#' - If \eqn{ Z_{max} Z_{mdn} > 0 }{ Z_max x Z_mdn > 0}, +#' +#' - If \eqn{ Z_{max} Z_{mdn} > 0 }{ Z_max x Z_mdn > 0}, #' the triad is balanced if \eqn{ Z_{max} Z_{mdn} - Z_{min} <= crit } #' { Z_max x Z_mdn - Z_min <= crit }. -#' - If \eqn{ Z_{max} Z_{mdn} < 0 }{ Z_max x Z_mdn < 0}, +#' - If \eqn{ Z_{max} Z_{mdn} < 0 }{ Z_max x Z_mdn < 0}, #' the triad is balanced if \eqn{ Z_{min} - Z_{max} Z_{mdn} <= crit } #' { Z_min - Z_max x Z_mdn <= crit }. -#' +#' #' @section Personal remarks (MH): I am a bit suspicious about step 2 from above. To devide by 3 appears pretty arbitrary. #' The r for a z-values of 3 is 0.9950548 and not 1. #' The r for 4 is 0.9993293. Hence, why not a value of 4, 5, or 6? @@ -1149,83 +1204,89 @@ indexConflict1 <- function(x) { #' @param x A `repgrid` object. #' @param crit Sensitivity criterion with which triads are marked as unbalanced. A bigger values will lead to less #' imbalanced triads. The default is `0.03`. The value should be adjusted with regard to the researchers interest. -#' +#' #' @references Bassler, M., Krauthauser, H., & Hoffmann, S. O. (1992). A new approach to the identification of #' cognitive conflicts in the repertory grid: An illustrative case study. #' *Journal of Constructivist Psychology, 5*(1), 95-111. #' #' Slade, P. D., & Sheehan, M. J. (1979). The measurement of 'conflict' in repertory grids. *British Journal of #' Psychology, 70*(4), 519-524. -#' +#' #' @seealso See [indexConflict1()] for the older version of this measure; see [indexConflict3()] for a measure based #' on distances instead of correlations. #' @examples #' -#' indexConflict2(bell2010) -#' -#' x <- indexConflict2(bell2010) -#' print(x) -#' -#' # show conflictive triads -#' print(x, output = 2) -#' -#' # accessing the calculations for further use -#' x$total -#' x$imbalanced -#' x$prop.balanced -#' x$prop.imbalanced -#' x$triads.imbalanced -#' +#' indexConflict2(bell2010) +#' +#' x <- indexConflict2(bell2010) +#' print(x) +#' +#' # show conflictive triads +#' print(x, output = 2) +#' +#' # accessing the calculations for further use +#' x$total +#' x$imbalanced +#' x$prop.balanced +#' x$prop.imbalanced +#' x$triads.imbalanced +#' #' @export indexConflict2 <- function(x, crit = .03) { - if (!inherits(x, "repgrid")) + if (!inherits(x, "repgrid")) { stop("Object must be of class 'repgrid'") + } - r <- constructCor(x) # construct correlation matrix + r <- constructCor(x) # construct correlation matrix z <- fisherz(r) - nc <- getNoOfConstructs(x) # number of constructs - comb <- t(combn(nc, 3)) # all possible correlation triads - balanced <- rep(NA, nrow(comb)) # set up result vector - - for (i in 1:nrow(comb)) { - z.triad <- z[t(combn(comb[i, ], 2))] # z-values of triad - ind <- order(abs(z.triad), decreasing = TRUE) # order for absolute magnitude - z.triad <- z.triad[ind] # reorder z values by magnitude - z.12 <- prod(z.triad[1:2]) # product of two biggest z values - z.3 <- z.triad[3] # minimal absolute z value + nc <- getNoOfConstructs(x) # number of constructs + comb <- t(combn(nc, 3)) # all possible correlation triads + balanced <- rep(NA, nrow(comb)) # set up result vector + + for (i in 1:nrow(comb)) { + z.triad <- z[t(combn(comb[i, ], 2))] # z-values of triad + ind <- order(abs(z.triad), decreasing = TRUE) # order for absolute magnitude + z.triad <- z.triad[ind] # reorder z values by magnitude + z.12 <- prod(z.triad[1:2]) # product of two biggest z values + z.3 <- z.triad[3] # minimal absolute z value # select case for inequality relation assessment if (sign(z.12) > 0) { balanced[i] <- z.12 - z.3 <= crit } else { balanced[i] <- z.3 - z.12 <= crit - } - } - prop.balanced <- sum(balanced) / length(balanced) # proportion of - prop.imbalanced <- 1 - prop.balanced # proportion of - - res <- list(total = length(balanced), - imbalanced = sum(!balanced), - prop.balanced = prop.balanced, - prop.imbalanced = prop.imbalanced, - triads.imbalanced = comb[!balanced, ]) + } + } + prop.balanced <- sum(balanced) / length(balanced) # proportion of + prop.imbalanced <- 1 - prop.balanced # proportion of + + res <- list( + total = length(balanced), + imbalanced = sum(!balanced), + prop.balanced = prop.balanced, + prop.imbalanced = prop.imbalanced, + triads.imbalanced = comb[!balanced, ] + ) class(res) <- "indexConflict2" res } -indexConflict2Out1 <- function(x, digits=1) -{ +indexConflict2Out1 <- function(x, digits = 1) { cat("\n###############################") cat("\nConflicts based on correlations") - cat("\n###############################") + cat("\n###############################") cat("\n\nAs devised by Bassler et al. (1992)") - + cat("\n\nTotal number of triads:", x$total) - cat("\nNumber of imbalanced triads:", x$imbalanced) - cat("\n\nProportion of balanced triads:", - round(x$prop.balanced * 100, digits = digits), "%") - cat("\nProportion of imbalanced triads:", - round(x$prop.imbalanced * 100, digits = digits), "%\n") + cat("\nNumber of imbalanced triads:", x$imbalanced) + cat( + "\n\nProportion of balanced triads:", + round(x$prop.balanced * 100, digits = digits), "%" + ) + cat( + "\nProportion of imbalanced triads:", + round(x$prop.imbalanced * 100, digits = digits), "%\n" + ) } @@ -1247,12 +1308,13 @@ indexConflict2Out2 <- function(x) { #' @export #' @method print indexConflict2 #' @keywords internal -#' +#' print.indexConflict2 <- function(x, digits = 1, output = 1, ...) { - indexConflict2Out1(x, digits = digits) - if (output == 2) + indexConflict2Out1(x, digits = digits) + if (output == 2) { indexConflict2Out2(x) -} + } +} #' Conflict or inconsistency measure for grids (Bell, 2004) based on distances. @@ -1268,9 +1330,9 @@ print.indexConflict2 <- function(x, digits = 1, output = 1, ...) { #' element by construct level making it valuable for detailed feedback. Also, #' differences in conflict can be submitted to statistical testing procedures. #' -#' Status: working; output for euclidean and manhattan distance +#' Status: working; output for euclidean and manhattan distance #' checked against Gridstat output. \cr -#' TODO: standardization and z-test for discrepancies; +#' TODO: standardization and z-test for discrepancies; #' Index of Conflict Variation. #' #' @param x `repgrid` object. @@ -1279,25 +1341,25 @@ print.indexConflict2 <- function(x, digits = 1, output = 1, ...) { #' distances. #' @param e.out Numeric. A vector giving the indexes of the elements #' for which detailed stats (number of conflicts per element, -#' discrepancies for triangles etc.) are prompted +#' discrepancies for triangles etc.) are prompted #' (default `NA`, i.e. no detailed stats for any element). -#' @param e.threshold Numeric. Detailed stats are prompted for those elements with a an -#' attributable percentage to the overall conflicts +#' @param e.threshold Numeric. Detailed stats are prompted for those elements with a an +#' attributable percentage to the overall conflicts #' higher than the supplied threshold #' (default `NA`). #' @param c.out Numeric. A vector giving the indexes of the constructs -#' for which detailed stats (discrepancies for triangles etc.) +#' for which detailed stats (discrepancies for triangles etc.) #' are prompted (default `NA`, i. e. no detailed stats). -#' @param c.threshold Numeric. Detailed stats are prompted for those constructs with a an -#' attributable percentage to the overall conflicts +#' @param c.threshold Numeric. Detailed stats are prompted for those constructs with a an +#' attributable percentage to the overall conflicts #' higher than the supplied threshold #' (default `NA`). #' @param trim The number of characters a construct (element) is trimmed to (default is #' `10`). If `NA` no trimming is done. Trimming #' simply saves space when displaying the output. #' -#' @return A list (invisibly) containing: -#' +#' @return A list (invisibly) containing: +#' #' - `potential`: number of potential conflicts #' - `actual`: count of actual conflicts #' - `overall`: percentage of conflictive relations @@ -1312,35 +1374,35 @@ print.indexConflict2 <- function(x, digits = 1, output = 1, ...) { #' - `enames`: trimmed element names. Used by print method #' - `cnames`: trimmed construct names. Used by print method #' -#' @references Bell, R. C. (2004). A new approach to measuring inconsistency +#' @references Bell, R. C. (2004). A new approach to measuring inconsistency #' or conflict in grids. *Personal Construct Theory & Practice*, (1), 53-59. -#' +#' #' @section output: For further control over the output see [print.indexConflict3()]. #' @export #' @seealso See [indexConflict1()] and [indexConflict2()] for conflict measures based on triads of correlations. -#' @examples -#' # calculate conflicts -#' indexConflict3(bell2010) -#' -#' # show additional stats for elements 1 to 3 -#' indexConflict3(bell2010, e.out = 1:3) -#' -#' # show additional stats for constructs 1 and 5 -#' indexConflict3(bell2010, c.out = c(1,5)) -#' -#' # finetune output -#' ## change number of digits -#' x <- indexConflict3(bell2010) -#' print(x, digits = 4) -#' -#' ## omit discrepancy matrices for constructs -#' x <- indexConflict3(bell2010, c.out = 5:6) -#' print(x, discrepancies = FALSE) -#' -indexConflict3 <- function(x, p = 2, - e.out = NA, +#' @examples +#' # calculate conflicts +#' indexConflict3(bell2010) +#' +#' # show additional stats for elements 1 to 3 +#' indexConflict3(bell2010, e.out = 1:3) +#' +#' # show additional stats for constructs 1 and 5 +#' indexConflict3(bell2010, c.out = c(1, 5)) +#' +#' # finetune output +#' ## change number of digits +#' x <- indexConflict3(bell2010) +#' print(x, digits = 4) +#' +#' ## omit discrepancy matrices for constructs +#' x <- indexConflict3(bell2010, c.out = 5:6) +#' print(x, discrepancies = FALSE) +#' +indexConflict3 <- function(x, p = 2, + e.out = NA, e.threshold = NA, - c.out = NA, + c.out = NA, c.threshold = NA, trim = 20) { # To assess the triangle inequality we need: @@ -1353,161 +1415,174 @@ indexConflict3 <- function(x, p = 2, # be the rating of element i on construct j. # The distance between the constructs it the distance (euclidean or city block) # between them without taking into account the element under consideration. - - s <- getRatingLayer(x) # grid scores matrix + + s <- getRatingLayer(x) # grid scores matrix ne <- getNoOfElements(x) nc <- getNoOfConstructs(x) - enames <- getElementNames2(x, index = T, trim = trim, pre = "", post = " ") + enames <- getElementNames2(x, index = T, trim = trim, pre = "", post = " ") cnames <- getConstructNames2(x, index = T, trim = trim, mode = 1, pre = "", post = " ") - + # set up result vectors # confict.disc discrepancy for each triangle (indexed e, c1, c2) # confict.e number of conflicts for each element # conflict.c number of conflicts for each construct # conflict.total overall value of conflictive triangles - conflict.disc <- array(NA, dim = c(nc, nc, ne)) - conflict.e <- rep(0, ne) - conflict.c <- rep(0, nc) + conflict.disc <- array(NA, dim = c(nc, nc, ne)) + conflict.e <- rep(0, ne) + conflict.c <- rep(0, nc) conflict.total <- 0 - conflicts.potential <- ne * nc * (nc - 1 ) / 2 + conflicts.potential <- ne * nc * (nc - 1) / 2 # e is i, c1 is j and c2 is k in Bell's Fortran code - + for (e in seq_len(ne)) { # average distance between constructs c1 and c2 not taking into account # the element under consideration. Generalization for any minkwoski metric - dc <- dist(s[, -e], method = "minkowski", p = p) / (ne - 1)^(1 / p) # Bell averages the unsquared distances (euclidean), - dc <- as.matrix(dc) # convert dist object to matrix # i.e. divide euclidean dist by root of n or p in the general case - + dc <- dist(s[, -e], method = "minkowski", p = p) / (ne - 1)^(1 / p) # Bell averages the unsquared distances (euclidean), + dc <- as.matrix(dc) # convert dist object to matrix # i.e. divide euclidean dist by root of n or p in the general case + for (c1 in seq_len(nc)) { for (c2 in seq_len(nc)) { if (c1 < c2) { d.jk <- dc[c1, c2] d.ij <- s[c1, e] d.ik <- s[c2, e] - - # assess if triangle inequality fails., i.e. if one distance is bigger + + # assess if triangle inequality fails., i.e. if one distance is bigger # than the sum of the other two distances. The magnitude it is bigger # is recorded in disc (discrepancy) - if (d.ij > (d.ik + d.jk)) - disc <- d.ij - (d.ik + d.jk) else - if (d.ik > (d.ij + d.jk)) - disc <- d.ik - (d.ij + d.jk) else - if (d.jk > (d.ij + d.ik)) - disc <- d.jk - (d.ij + d.ik) else - disc <- NA - + if (d.ij > (d.ik + d.jk)) { + disc <- d.ij - (d.ik + d.jk) + } else if (d.ik > (d.ij + d.jk)) { + disc <- d.ik - (d.ij + d.jk) + } else if (d.jk > (d.ij + d.ik)) { + disc <- d.jk - (d.ij + d.ik) + } else { + disc <- NA + } + # store size of discrepancy in confict.disc and record discrepancy # by element (confict.e) construct (confict.c) and overall (confict.total) if (!is.na(disc)) { - conflict.disc[c1, c2, e] <- disc - conflict.disc[c2, c1, e] <- disc - conflict.e[e] <- conflict.e[e] + 1 - conflict.c[c1] <- conflict.c[c1] + 1 - conflict.c[c2] <- conflict.c[c2] + 1 + conflict.disc[c1, c2, e] <- disc + conflict.disc[c2, c1, e] <- disc + conflict.e[e] <- conflict.e[e] + 1 + conflict.c[c1] <- conflict.c[c1] + 1 + conflict.c[c2] <- conflict.c[c2] + 1 conflict.total <- conflict.total + 1 } } - } + } } } - + # add e and c names to results - dimnames(conflict.disc)[[3]] <- enames + dimnames(conflict.disc)[[3]] <- enames conflict.e.df <- data.frame(percentage = conflict.e) rownames(conflict.e.df) <- enames conflict.c.df <- data.frame(percentage = conflict.c) rownames(conflict.c.df) <- cnames - - + + ### Detailed stats for elements ### - - conflictAttributedByConstructForElement <- function(e){ - e.disc.0 <- e.disc.na <- conflict.disc[ , , e] # version with NAs and zeros for no discrepancies - e.disc.0[is.na(e.disc.0)] <- 0 # replace NAs by zeros - - e.disc.no <- apply(!is.na(e.disc.na), 2, sum) # number of conflicts per construct - e.disc.perc <- e.disc.no / sum(e.disc.no) * 100 # no conf. per as percentage - e.disc.perc.df <- data.frame(percentage = e.disc.perc) # convert to dataframe - rownames(e.disc.perc.df) <- cnames # add rownames - - n.conflict.pairs <- sum(e.disc.no) / 2 # number of conflicting construct pairs all elements - disc.avg <- mean(e.disc.0) # average level of discrepancy - disc.sd <- sd(as.vector(e.disc.na), na.rm = TRUE) # sd of discrepancies - - disc.stand <- (e.disc.na - disc.avg) / disc.sd # standardized discrepancy - - list(e = e, - disc = e.disc.na, - pairs = n.conflict.pairs, - constructs = e.disc.perc.df, - avg = disc.avg, - sd = disc.sd)#, - #disc.stand=round(disc.stand, digits)) - } - - + + conflictAttributedByConstructForElement <- function(e) { + e.disc.0 <- e.disc.na <- conflict.disc[, , e] # version with NAs and zeros for no discrepancies + e.disc.0[is.na(e.disc.0)] <- 0 # replace NAs by zeros + + e.disc.no <- apply(!is.na(e.disc.na), 2, sum) # number of conflicts per construct + e.disc.perc <- e.disc.no / sum(e.disc.no) * 100 # no conf. per as percentage + e.disc.perc.df <- data.frame(percentage = e.disc.perc) # convert to dataframe + rownames(e.disc.perc.df) <- cnames # add rownames + + n.conflict.pairs <- sum(e.disc.no) / 2 # number of conflicting construct pairs all elements + disc.avg <- mean(e.disc.0) # average level of discrepancy + disc.sd <- sd(as.vector(e.disc.na), na.rm = TRUE) # sd of discrepancies + + disc.stand <- (e.disc.na - disc.avg) / disc.sd # standardized discrepancy + + list( + e = e, + disc = e.disc.na, + pairs = n.conflict.pairs, + constructs = e.disc.perc.df, + avg = disc.avg, + sd = disc.sd + ) # , + # disc.stand=round(disc.stand, digits)) + } + + ### Detailed stats for constructs ### - - conflictAttributedByElementForConstruct <- function(c1) - { - c1.disc.0 <- c1.disc.na <- conflict.disc[c1, , ] # version with NAs and zeros for no discrepancies + + conflictAttributedByElementForConstruct <- function(c1) { + c1.disc.0 <- c1.disc.na <- conflict.disc[c1, , ] # version with NAs and zeros for no discrepancies rownames(c1.disc.na) <- paste("c", seq_len(nrow(c1.disc.na))) colnames(c1.disc.na) <- paste("e", seq_len(ncol(c1.disc.na))) - - c1.disc.0[is.na(c1.disc.0)] <- 0 # replace NAs by zeros - - disc.avg <- mean(c1.disc.0) # average level of discrepancy - disc.sd <- sd(as.vector(c1.disc.na), na.rm = TRUE) # sd of discrepancies - list(c1 = c1, - disc = c1.disc.na, - avg = disc.avg, - sd = disc.sd)#, - #disc.stand=round(disc.stand, digits)) - } - + + c1.disc.0[is.na(c1.disc.0)] <- 0 # replace NAs by zeros + + disc.avg <- mean(c1.disc.0) # average level of discrepancy + disc.sd <- sd(as.vector(c1.disc.na), na.rm = TRUE) # sd of discrepancies + list( + c1 = c1, + disc = c1.disc.na, + avg = disc.avg, + sd = disc.sd + ) # , + # disc.stand=round(disc.stand, digits)) + } + # Select which detailed stats for elements. Either all bigger than # a threshold or the ones selected manually. - if (!is.na(e.out[1])) - e.select <- e.out else - if (!is.na(e.threshold[1])) - e.select <- which(conflict.e / conflict.total * 100 > e.threshold) else - e.select <- NA - - e.stats <- list() # list with detailed results + if (!is.na(e.out[1])) { + e.select <- e.out + } else if (!is.na(e.threshold[1])) { + e.select <- which(conflict.e / conflict.total * 100 > e.threshold) + } else { + e.select <- NA + } + + e.stats <- list() # list with detailed results if (!is.na(e.select[1])) { - for (e in seq_along(e.select)) - e.stats[[e]] <- conflictAttributedByConstructForElement(e.select[e]) - names(e.stats) <- enames[e.select] + for (e in seq_along(e.select)) { + e.stats[[e]] <- conflictAttributedByConstructForElement(e.select[e]) + } + names(e.stats) <- enames[e.select] } - + # Select which detailed stats for constructs. Either all bigger than # a threshold or the ones selected manually. - if (!is.na(c.out[1])) - c.select <- c.out else - if (!is.na(c.threshold[1])) - c.select <- which(.5 * conflict.c / conflict.total * 100 > c.threshold) else - c.select <- NA - - c.stats <- list() # list with detailed results + if (!is.na(c.out[1])) { + c.select <- c.out + } else if (!is.na(c.threshold[1])) { + c.select <- which(.5 * conflict.c / conflict.total * 100 > c.threshold) + } else { + c.select <- NA + } + + c.stats <- list() # list with detailed results if (!is.na(c.select[1])) { - for (c in seq_along(c.select)) + for (c in seq_along(c.select)) { c.stats[[c]] <- conflictAttributedByElementForConstruct(c.select[c]) - names(c.stats) <- cnames[c.select] - } - - res <- list(potential = conflicts.potential, - actual = conflict.total, - overall = conflict.total/conflicts.potential * 100, - e.count = conflict.e, - e.perc = conflict.e.df / conflict.total * 100, - c.count = conflict.c, - c.perc = .5 * conflict.c.df / conflict.total * 100, - e.stats = e.stats, - c.stats = c.stats, - e.threshold = e.threshold, # threshold for elements - c.threshold = c.threshold, - enames = enames, # element names - cnames = cnames) + } + names(c.stats) <- cnames[c.select] + } + + res <- list( + potential = conflicts.potential, + actual = conflict.total, + overall = conflict.total / conflicts.potential * 100, + e.count = conflict.e, + e.perc = conflict.e.df / conflict.total * 100, + c.count = conflict.c, + c.perc = .5 * conflict.c.df / conflict.total * 100, + e.stats = e.stats, + c.stats = c.stats, + e.threshold = e.threshold, # threshold for elements + c.threshold = c.threshold, + enames = enames, # element names + cnames = cnames + ) class(res) <- "indexConflict3" res } @@ -1519,41 +1594,45 @@ indexConflict3Out1 <- function(x, digits = 1) { cat("\nCONFLICT OR INCONSISTENCIES BASED ON TRIANGLE INEQUALITIES") cat("\n##########################################################\n") cat("\nPotential conflicts in grid: ", x$potential) - cat("\nActual conflicts in grid: ", x$actual) - cat("\nOverall percentage of conflict in grid: ", - round(x$actual / x$potential * 100, digits), "%\n") - + cat("\nActual conflicts in grid: ", x$actual) + cat( + "\nOverall percentage of conflict in grid: ", + round(x$actual / x$potential * 100, digits), "%\n" + ) + cat("\nELEMENTS") cat("\n########\n") cat("\nPercent of conflict attributable to element:\n\n") - print(round(x$e.perc * 100, digits)) + print(round(x$e.perc * 100, digits)) cat("\nChi-square test of equal count of conflicts for elements.\n") print(chisq.test(x$e.count)) - + cat("\nCONSTRUCTS") cat("\n##########\n") cat("\nPercent of conflict attributable to construct:\n\n") - print(round(x$c.perc , digits)) + print(round(x$c.perc, digits)) cat("\nChi-square test of equal count of conflicts for constructs.\n") print(chisq.test(x$c.count)) - #print(sd(conflict.c.perc)) - #print(var(conflict.c.perc)) + # print(sd(conflict.c.perc)) + # print(var(conflict.c.perc)) } -indexConflict3Out2 <- function(x, digits=1, discrepancies=TRUE) { +indexConflict3Out2 <- function(x, digits = 1, discrepancies = TRUE) { e.stats <- x$e.stats e.threshold <- x$e.threshold enames <- x$enames - - if (length(e.stats) == 0) # stop function in case + + if (length(e.stats) == 0) { # stop function in case return(NULL) - + } + cat("\n\nCONFLICTS BY ELEMENT") cat("\n####################\n") - if (!is.na(e.threshold)) + if (!is.na(e.threshold)) { cat("(Details for elements with conflict >", e.threshold, "%)\n") - + } + for (e in seq_along(e.stats)) { m <- e.stats[[e]] if (!is.null(m)) { @@ -1562,10 +1641,12 @@ indexConflict3Out2 <- function(x, digits=1, discrepancies=TRUE) { if (discrepancies) { cat("\nConstruct conflict discrepancies:\n\n") disc <- round(m$disc, digits) - print(as.data.frame(formatMatrix(disc, rnames = "", - mode = 2, diag = FALSE), stringsAsFactors = FALSE)) + print(as.data.frame(formatMatrix(disc, + rnames = "", + mode = 2, diag = FALSE + ), stringsAsFactors = FALSE)) } - cat("\nPercent of conflict attributable to each construct:\n\n") + cat("\nPercent of conflict attributable to each construct:\n\n") print(round(m$constructs, digits)) cat("\nAv. level of discrepancy: ", round(m$avg, digits), "\n") cat("\nStd. dev. of discrepancies: ", round(m$sd, digits + 1), "\n") @@ -1578,15 +1659,17 @@ indexConflict3Out3 <- function(x, digits = 1, discrepancies = TRUE) { c.threshold <- x$c.threshold c.stats <- x$c.stats cnames <- x$cnames - - if (length(c.stats) == 0) # stop function in case + + if (length(c.stats) == 0) { # stop function in case return(NULL) - + } + cat("\n\nCONFLICTS BY CONSTRUCT") cat("\n######################\n") - if (!is.na(c.threshold)) + if (!is.na(c.threshold)) { cat("(Details for constructs with conflict >", c.threshold, "%)\n") - + } + for (c in seq_along(c.stats)) { x <- c.stats[[c]] if (!is.null(x)) { @@ -1594,11 +1677,12 @@ indexConflict3Out3 <- function(x, digits = 1, discrepancies = TRUE) { if (discrepancies) { cat("\nElement-construct conflict discrepancies:\n\n") disc <- round(x$disc, digits) - print(as.data.frame(formatMatrix(disc, - rnames = paste("c", seq_len(nrow(x$disc)), sep = ""), - cnames = paste("e", seq_len(ncol(x$disc)), sep = ""), - pre.index = c(FALSE, FALSE), - mode = 2, diag = FALSE), stringsAsFactors = FALSE)) + print(as.data.frame(formatMatrix(disc, + rnames = paste("c", seq_len(nrow(x$disc)), sep = ""), + cnames = paste("e", seq_len(ncol(x$disc)), sep = ""), + pre.index = c(FALSE, FALSE), + mode = 2, diag = FALSE + ), stringsAsFactors = FALSE)) } cat("\nAv. level of discrepancy: ", round(x$avg, digits), "\n") cat("\nStd. dev. of discrepancies: ", round(x$sd, digits + 1), "\n") @@ -1619,12 +1703,13 @@ indexConflict3Out3 <- function(x, digits = 1, discrepancies = TRUE) { #' @export #' @method print indexConflict3 #' @keywords internal -#' +#' print.indexConflict3 <- function(x, digits = 2, output = 1, discrepancies = TRUE, ...) { - if (output == 1) - indexConflict3Out1(x, digits = digits) + if (output == 1) { + indexConflict3Out1(x, digits = digits) + } indexConflict3Out2(x, digits = digits, discrepancies = discrepancies) - indexConflict3Out3(x, digits = digits, discrepancies = discrepancies) + indexConflict3Out3(x, digits = digits, discrepancies = discrepancies) } @@ -1634,27 +1719,33 @@ print.indexConflict3 <- function(x, digits = 2, output = 1, discrepancies = TRUE # plots distribution of construct correlations # indexDilemmaShowCorrelationDistribution <- function(x, e1, e2) { - rc.including <- constructCor(x) + rc.including <- constructCor(x) rc.excluding <- constructCor(x[, -c(e1, e2)]) rc.inc.vals <- abs(rc.including[lower.tri(rc.including)]) rc.exc.vals <- abs(rc.excluding[lower.tri(rc.excluding)]) - + histDensity <- function(vals, probs = c(.2, .4, .6, .8, .9), ...) { - h <- hist(vals, breaks = seq(0, 1.01, len = 21), freq = FALSE, - xlim = c(0, 1), border = "white", col = grey(.8), ...) + h <- hist(vals, + breaks = seq(0, 1.01, len = 21), freq = FALSE, + xlim = c(0, 1), border = "white", col = grey(.8), ... + ) d <- density(vals) lines(d$x, d$y) q <- quantile(vals, probs = probs) abline(v = q, col = "red") - text(q, 0, paste(round(probs * 100, 0), "%"), cex = .8, pos = 2, col = "red") - } - - layout(matrix(c(1,2), ncol = 1)) - par(mar = c(3,4.2,2.4,2)) - histDensity(rc.inc.vals, cex.main = .8, cex.axis = .8, cex.lab = .8, - main = "Distribution of absolute construct-correlations \n(including 'self' and 'ideal self')") - histDensity(rc.exc.vals, cex.main = .8, cex.axis = .8, cex.lab = .8, - main = "Distribution of absolute construct-correlations \n(excluding 'self' and 'ideal self')") + text(q, 0, paste(round(probs * 100, 0), "%"), cex = .8, pos = 2, col = "red") + } + + layout(matrix(c(1, 2), ncol = 1)) + par(mar = c(3, 4.2, 2.4, 2)) + histDensity(rc.inc.vals, + cex.main = .8, cex.axis = .8, cex.lab = .8, + main = "Distribution of absolute construct-correlations \n(including 'self' and 'ideal self')" + ) + histDensity(rc.exc.vals, + cex.main = .8, cex.axis = .8, cex.lab = .8, + main = "Distribution of absolute construct-correlations \n(excluding 'self' and 'ideal self')" + ) } @@ -1662,9 +1753,9 @@ indexDilemmaShowCorrelationDistribution <- function(x, e1, e2) { # # @param x \code{repgrid} object. # @param self Numeric. Index of self element. -# @param ideal Numeric. Index of ideal self element. -# @param diff.mode Numeric. Method adopted to classify construct pairs into congruent -# and discrepant. With \code{diff.mode=1}, the minimal and maximal +# @param ideal Numeric. Index of ideal self element. +# @param diff.mode Numeric. Method adopted to classify construct pairs into congruent +# and discrepant. With \code{diff.mode=1}, the minimal and maximal # score difference criterion is applied. With \code{diff.mode=0} the Mid-point # rating criterion is applied. Default is \code{diff.mode=1}. @@ -1681,47 +1772,53 @@ indexDilemmaShowCorrelationDistribution <- function(x, e1, e2) { # @param diff.poles Not yet implemented. # @param r.min Minimal correlation to determine implications between # constructs ([0, 1]). -# @param exclude Whether to exclude the elements self and ideal self +# @param exclude Whether to exclude the elements self and ideal self # during the calculation of the inter-construct correlations. # (default is \code{FALSE}). -# @param index Whether to print index numbers in front of each construct +# @param index Whether to print index numbers in front of each construct # (default is \code{TRUE}). # @param trim The number of characters a construct (element) is trimmed to (default is # \code{20}). If \code{NA} no trimming is done. Trimming # simply saves space when displaying the output. -# @param digits Numeric. Number of digits to round to (default is +# @param digits Numeric. Number of digits to round to (default is # \code{2}). # @export # @keywords internal -# @return A list with four elements containing different steps of the +# @return A list with four elements containing different steps of the # calculation. # # -indexDilemmaInternal <- function(x, self, ideal, - diff.mode = 1, diff.congruent = 1, - diff.discrepant = 4, diff.poles = 1, - r.min, exclude = FALSE, digits = 2, - index = T, trim = FALSE) { +indexDilemmaInternal <- function(x, self, ideal, + diff.mode = 1, diff.congruent = 1, + diff.discrepant = 4, diff.poles = 1, + r.min, exclude = FALSE, digits = 2, + index = T, trim = FALSE) { nc <- nrow(x) ne <- ncol(x) enames <- elements(x) e_ii <- seq_len(ne) # possible element indexes - - if (!self %in% e_ii) + + if (!self %in% e_ii) { stop("'self' element index must be within interval [", 1, ",", ne, "]", call. = FALSE) - if (!ideal %in% e_ii) + } + if (!ideal %in% e_ii) { stop("'ideal' element index must be within interval [", 1, ",", ne, "]", call. = FALSE) - if (diff.congruent < 0) + } + if (diff.congruent < 0) { stop("'diff.congruent' must be non-negative", call. = FALSE) - if (diff.discrepant < 0) + } + if (diff.discrepant < 0) { stop("'diff.discrepant' must be non-negative", call. = FALSE) - if (diff.congruent >= diff.discrepant) + } + if (diff.congruent >= diff.discrepant) { stop("'diff.congruent' must be smaller than 'diff.discrepant'", call. = FALSE) - if (r.min < 0 | r.min > 1 ) + } + if (r.min < 0 | r.min > 1) { stop("'r.min' must lie in interval [0, 1]", call. = FALSE) + } # r.min <- abs(r.min) # direction does not matter the way we process - s <- ratings(x) # grid scores matrix + s <- ratings(x) # grid scores matrix # create a vector of inverted scores for the 'self' element: # invscr = 8 - scr # Example: 2 -> 8 - 2 -> 6 @@ -1729,26 +1826,26 @@ indexDilemmaInternal <- function(x, self, ideal, s_inverted <- ratings(swapPoles(x)) # grid with inverted scores cnames <- getConstructNames2(x, index = index, trim = trim, mode = 1, pre = "", post = " ") sc <- getScale(x) - midpoint <- getScaleMidpoint(x) # NEW (DIEGO) get scale midpoint this is importat in - # when Alejandro's code check whether self/ideal - # is == to the midpoint or not (see below "Get Dilemmas" section) - - # FLAG ALL CONSTRUCTS AS DISCREPANT, CONGRUENT OR NEITHER - - diff.between <- abs(s[, self] - s[, ideal]) # self - ideal difference + midpoint <- getScaleMidpoint(x) # NEW (DIEGO) get scale midpoint this is importat in + # when Alejandro's code check whether self/ideal + # is == to the midpoint or not (see below "Get Dilemmas" section) + + # FLAG ALL CONSTRUCTS AS DISCREPANT, CONGRUENT OR NEITHER + + diff.between <- abs(s[, self] - s[, ideal]) # self - ideal difference is.congruent <- logical() type.c <- character() - - # CORRECTION (ALEJANDRO): - # a construct can't be congruent if it's 'self' score is 4 (AKA self-disorientation). + + # CORRECTION (ALEJANDRO): + # a construct can't be congruent if it's 'self' score is 4 (AKA self-disorientation). # Neither can be congruent if IDEAL is 4 (i.e. midpoint). # CORRECTION (Diego): I have just updated this avoid hardcoding the midpoint!! if (diff.mode == 1) { for (i in 1L:nc) { if (s[, self][i] != midpoint) { if (s[, ideal][i] != midpoint) { - is.congruent[i] <- diff.between[i] <= diff.congruent - } else{ + is.congruent[i] <- diff.between[i] <= diff.congruent + } else { is.congruent[i] <- FALSE } } else { @@ -1757,12 +1854,12 @@ indexDilemmaInternal <- function(x, self, ideal, } is.discrepant <- diff.between >= diff.discrepant is.neither <- !is.congruent & !is.discrepant - + type.c[is.congruent] <- "congruent" type.c[is.discrepant] <- "discrepant" type.c[is.neither] <- "neither" } - + # # difference from poles NOT YET IMPLEMENTED # sc <- getScale(x) # diff.pole1 <- abs(s[, c(e.self, e.ideal)] - sc[1]) @@ -1772,33 +1869,32 @@ indexDilemmaInternal <- function(x, self, ideal, # diff.pole2[,1] <= diff.poles & diff.pole2[,2] <= diff.poles # is.discrepant.p <- diff.pole1[,1] <= diff.poles & diff.pole2[,2] <= diff.poles | # diff.pole1[,1] <= diff.poles & diff.pole2[,2] <= diff.poles - # - # is.neither.p <- !is.congruent.p & !is.discrepant.p + # + # is.neither.p <- !is.congruent.p & !is.discrepant.p # type.c.poles[is.congruent.p] <- "congruent" # type.c.poles[is.discrepant.p] <- "discrepant" # type.c.poles[is.neither.p] <- "neither" # # - #////////////////////////////////////////////////////////////////////////////// - ## MIDPOINT-BASED CRITERION TO IDENTIFY CONGRUENT AND DISCREPANT constructs - #////////////////////////////////////////////////////////////////////////////// + # ////////////////////////////////////////////////////////////////////////////// + ## MIDPOINT-BASED CRITERION TO IDENTIFY CONGRUENT AND DISCREPANT constructs + # ////////////////////////////////////////////////////////////////////////////// #### added by DIEGO - # I have tried to implement here the other popular method for the identification of + # I have tried to implement here the other popular method for the identification of # Congruent and Discrepant constructs. This proposed below is that applied by IDIOGRID # software (V.2.3) - # IDIOGRID uses "the scale midpoint as the 'dividing line' for discrepancies; for example, - # if the actual self (the Subject Element) is rated above the scale midpoint and the ideal - # self (the Target Element) is rated below the midpoint, then a discrepancy exists (and - # vice versa). If the two selves are rated on the same side of the scale or if either - # the actual self or the ideal self are rated at the midpoint of the scale, then a discre- + # IDIOGRID uses "the scale midpoint as the 'dividing line' for discrepancies; for example, + # if the actual self (the Subject Element) is rated above the scale midpoint and the ideal + # self (the Target Element) is rated below the midpoint, then a discrepancy exists (and + # vice versa). If the two selves are rated on the same side of the scale or if either + # the actual self or the ideal self are rated at the midpoint of the scale, then a discre- # pancy does not exist." (from IDIOGRID manual) else if (diff.mode == 0) { - - is.congruent <- (s[, self] < midpoint & s[, ideal] < midpoint) | - (s[, self] > midpoint & s[, ideal] > midpoint) - is.discrepant <- (s[, self] < midpoint & s[, ideal] > midpoint) | - (s[, self] > midpoint & s[, ideal] < midpoint) + is.congruent <- (s[, self] < midpoint & s[, ideal] < midpoint) | + (s[, self] > midpoint & s[, ideal] > midpoint) + is.discrepant <- (s[, self] < midpoint & s[, ideal] > midpoint) | + (s[, self] > midpoint & s[, ideal] < midpoint) is.neither <- !is.congruent & !is.discrepant type.c[is.congruent] <- "congruent" type.c[is.discrepant] <- "discrepant" @@ -1808,11 +1904,11 @@ indexDilemmaInternal <- function(x, self, ideal, } #--------------- END OF MIDPOINT-BASED CRITERION -----------------------------# - - #////////////////////////////////////////////////////////////////////////////// - # DIEGO: This that I have commented-out is now redundant as the variables are not duplicates + + # ////////////////////////////////////////////////////////////////////////////// + # DIEGO: This that I have commented-out is now redundant as the variables are not duplicates # anymore and are calculated only in their conditional loop. This is more efficient - #////////////////////////////////////////////////////////////////////////////// + # ////////////////////////////////////////////////////////////////////////////// # if (diff.mode == 1){ # is.congruent <- is.congruent.e # is.discrepant <- is.discrepant.e @@ -1820,194 +1916,205 @@ indexDilemmaInternal <- function(x, self, ideal, # } else if (diff.mode == 0){ ##### ADDED CHOICE "0" for MIDPOINT RATING CRITERION # is.congruent <- is.congruent.p # is.discrepant <- is.discrepant.p - # type.construct <- type.c.poles + # type.construct <- type.c.poles # } # we just need the next line to reconnect with the original indexdilemma routine - #////////////////////////////////////////////////////////////////////////////// - + # ////////////////////////////////////////////////////////////////////////////// + type.construct <- type.c # GET CORRELATIONS - - # inter-construct correlations including and excluding + + # inter-construct correlations including and excluding # the elements self and ideal self - rc.include <- constructCor(x) # TODO digits=digits - rc.exclude <- constructCor(x[, -c(self, ideal)]) #digits=digits - + rc.include <- constructCor(x) # TODO digits=digits + rc.exclude <- constructCor(x[, -c(self, ideal)]) # digits=digits + # correlations to use for evaluation if (exclude) { - rc.use <- rc.exclude + rc.use <- rc.exclude } else { rc.use <- rc.include } - + # type.c.poles <- type.c.elem <- rep(NA, nrow(s)) # set up results vectors type.c <- rep(NA, nrow(s)) # GET DILEMMAS - + # which pairs of absolute construct correlations are bigger than r.min? comb <- t(combn(nc, 2)) # all possible correlation pairs (don't repeat) - n_construct_pairs <- nrow(comb) # = factorial(n) / (2*factorial(n - 2)) + n_construct_pairs <- nrow(comb) # = factorial(n) / (2*factorial(n - 2)) needs.to.invert <- logical() - + # set up result vectors check <- bigger.rmin <- r.include <- r.exclude <- type.c1 <- type.c2 <- rep(NA, nrow(comb)) - + # check every pair of constructs for characteristics for (i in 1L:nrow(comb)) { - c1 <- comb[i,1] - c2 <- comb[i,2] + c1 <- comb[i, 1] + c2 <- comb[i, 2] r.include[i] <- rc.include[c1, c2] r.exclude[i] <- rc.exclude[c1, c2] type.c1[i] <- type.construct[c1] type.c2[i] <- type.construct[c2] - + # CORRECTION: # To create a dilemma, the 'self' scores of both constructs must be # on the same pole. We have to check for that. - + # REMOVED HARDCODED MIDPOINT # DIEGO: 4 is the midpoint and it was "hardcoded". This is not good if we have a scoring range # that is not 1-7 because in that case the midpoint will NOT be 4! # # DIEGO: another bug-fix is that in the section where the scripts "reorient" the constructs: - # the code to re-orient the constructs is not controlling for self or ideal self to be scored - # as the midpoint. This causes the script break. I have added a condition for those combinations + # the code to re-orient the constructs is not controlling for self or ideal self to be scored + # as the midpoint. This causes the script break. I have added a condition for those combinations # equivalent to self-score != midpoint - + if (s[c1, self] != midpoint & s[c2, self] != midpoint) { - if (s[c1, self] > midpoint & s[c2, self] > midpoint) { - if (rc.use[c1, c2] >= r.min) # CORRECTION: don't use ABS values, + if (s[c1, self] > midpoint & s[c2, self] > midpoint) { + if (rc.use[c1, c2] >= r.min) { # CORRECTION: don't use ABS values, # we invert scores to check constructs # to find correlations the other way - bigger.rmin[i] <- TRUE else - bigger.rmin[i] <- FALSE - check[i] <- (is.congruent[c1] & is.discrepant[c2]) | - (is.discrepant[c1] & is.congruent[c2]) - needs.to.invert[c1] <- TRUE - needs.to.invert[c2] <- TRUE - } - else if (s[c1, self] < midpoint & s[c2, self] < midpoint) { - if (rc.use[c1, c2] >= r.min) - bigger.rmin[i] <- TRUE else - bigger.rmin[i] <- FALSE - check[i] <- (is.congruent[c1] & is.discrepant[c2]) | - (is.discrepant[c1] & is.congruent[c2]) - needs.to.invert[c1] <- FALSE - needs.to.invert[c2] <- FALSE + bigger.rmin[i] <- TRUE + } else { + bigger.rmin[i] <- FALSE + } + check[i] <- (is.congruent[c1] & is.discrepant[c2]) | + (is.discrepant[c1] & is.congruent[c2]) + needs.to.invert[c1] <- TRUE + needs.to.invert[c2] <- TRUE + } else if (s[c1, self] < midpoint & s[c2, self] < midpoint) { + if (rc.use[c1, c2] >= r.min) { + bigger.rmin[i] <- TRUE + } else { + bigger.rmin[i] <- FALSE + } + check[i] <- (is.congruent[c1] & is.discrepant[c2]) | + (is.discrepant[c1] & is.congruent[c2]) + needs.to.invert[c1] <- FALSE + needs.to.invert[c2] <- FALSE } - + # NEW: # Now check for inverted scores. # You only need to invert one construct at a time - + if (s_inverted[c1, self] > midpoint & s[c2, self] > midpoint) { - r.include[i] = cor(s_inverted[c1,], s[c2,]) - r.exclude[i] = "*Not implemented" - if (r.include[i] >= r.min) - bigger.rmin[i] <- TRUE else - bigger.rmin[i] <- FALSE + r.include[i] <- cor(s_inverted[c1, ], s[c2, ]) + r.exclude[i] <- "*Not implemented" + if (r.include[i] >= r.min) { + bigger.rmin[i] <- TRUE + } else { + bigger.rmin[i] <- FALSE + } check[i] <- (is.congruent[c1] & is.discrepant[c2]) | (is.discrepant[c1] & is.congruent[c2]) needs.to.invert[c2] <- TRUE - } - else if (s_inverted[c1, self] < midpoint & s[c2, self] < midpoint) { - r.include[i] = cor(s_inverted[c1,], s[c2,]) - r.exclude[i] = "*Not implemented" - if (r.include[i] >= r.min) - bigger.rmin[i] <- TRUE else - bigger.rmin[i] <- FALSE + } else if (s_inverted[c1, self] < midpoint & s[c2, self] < midpoint) { + r.include[i] <- cor(s_inverted[c1, ], s[c2, ]) + r.exclude[i] <- "*Not implemented" + if (r.include[i] >= r.min) { + bigger.rmin[i] <- TRUE + } else { + bigger.rmin[i] <- FALSE + } check[i] <- (is.congruent[c1] & is.discrepant[c2]) | (is.discrepant[c1] & is.congruent[c2]) needs.to.invert[c1] <- TRUE } - + if (s[c1, self] > midpoint & s_inverted[c2, self] > midpoint) { - r.include[i] = cor(s[c1,], s_inverted[c2,]) - r.exclude[i] = "*Not implemented" - if (r.include[i] >= r.min) - bigger.rmin[i] <- TRUE else - bigger.rmin[i] <- FALSE + r.include[i] <- cor(s[c1, ], s_inverted[c2, ]) + r.exclude[i] <- "*Not implemented" + if (r.include[i] >= r.min) { + bigger.rmin[i] <- TRUE + } else { + bigger.rmin[i] <- FALSE + } check[i] <- (is.congruent[c1] & is.discrepant[c2]) | (is.discrepant[c1] & is.congruent[c2]) needs.to.invert[c1] <- TRUE - } - else if (s[c1, self] < midpoint & s_inverted[c2, self] < midpoint) { - r.include[i] = cor(s[c1,], s_inverted[c2,]) - r.exclude[i] = "*Not implemented" - if (r.include[i] >= r.min) - bigger.rmin[i] <- TRUE else - bigger.rmin[i] <- FALSE + } else if (s[c1, self] < midpoint & s_inverted[c2, self] < midpoint) { + r.include[i] <- cor(s[c1, ], s_inverted[c2, ]) + r.exclude[i] <- "*Not implemented" + if (r.include[i] >= r.min) { + bigger.rmin[i] <- TRUE + } else { + bigger.rmin[i] <- FALSE + } check[i] <- (is.congruent[c1] & is.discrepant[c2]) | (is.discrepant[c1] & is.congruent[c2]) needs.to.invert[c2] <- TRUE } + } else { # DIEGO: closing of the if() where I put the condition for self to be != to the midpoint score + needs.to.invert[c1] <- FALSE + needs.to.invert[c2] <- FALSE } - else {# DIEGO: closing of the if() where I put the condition for self to be != to the midpoint score - needs.to.invert[c1] <- FALSE - needs.to.invert[c2] <- FALSE - } - #print(paste(needs.to.invert,s[c1,self],s[c2,self])) # Diego debug printout of variables + # print(paste(needs.to.invert,s[c1,self],s[c2,self])) # Diego debug printout of variables } # New: invert construct label poles if needed needs.to.invert[is.na(needs.to.invert)] <- FALSE - leftpole <- constructs(x)$leftpole + leftpole <- constructs(x)$leftpole rightpole <- constructs(x)$rightpole for (i in 1L:nc) { if (needs.to.invert[i]) { s[i, self] <- s_inverted[i, self] s[i, ideal] <- s_inverted[i, ideal] - cnames[i] = paste(rightpole[i], leftpole[i], sep = ' - ') + cnames[i] <- paste(rightpole[i], leftpole[i], sep = " - ") } else { - cnames[i] = paste(leftpole[i], rightpole[i], sep = ' - ') + cnames[i] <- paste(leftpole[i], rightpole[i], sep = " - ") } } - + # GET RESULTS - + ## 1: this data frame contains information related to 'self' and 'ideal' elements - construct_classification <- data.frame(construct = cnames, a.priori = type.construct, self = s[, self], ideal = s[, ideal], - stringsAsFactors = FALSE) + construct_classification <- data.frame( + construct = cnames, a.priori = type.construct, self = s[, self], ideal = s[, ideal], + stringsAsFactors = FALSE + ) colnames(construct_classification) <- c("Construct", "Classification", "Self", "Ideal") rownames(construct_classification) <- NULL - construct_classification <- construct_classification %>% + construct_classification <- construct_classification %>% dplyr::mutate( Difference = abs(Self - Ideal) - ) %>% + ) %>% select(Construct, Self, Ideal, Difference, Classification) - + ## 2: This dataframe stores the information for all posible construct combinations - all_pairs <- data.frame(c1 = comb[,1], c2 = comb[,2], r.inc = r.include, - r.exc = r.exclude, bigger.rmin, type.c1, type.c2, check, - name.c1 = cnames[comb[,1]], name.c2 = cnames[comb[,2]], - stringsAsFactors = FALSE) - + all_pairs <- data.frame( + c1 = comb[, 1], c2 = comb[, 2], r.inc = r.include, + r.exc = r.exclude, bigger.rmin, type.c1, type.c2, check, + name.c1 = cnames[comb[, 1]], name.c2 = cnames[comb[, 2]], + stringsAsFactors = FALSE + ) + ## 3: This dataframe contains information for all the dilemmas - dilemmas_info <- subset(all_pairs, check == TRUE & bigger.rmin == TRUE) - no_ids <- nrow(dilemmas_info) # Number of implicative dilemmas - cnstr.labels = character() + dilemmas_info <- subset(all_pairs, check == TRUE & bigger.rmin == TRUE) + no_ids <- nrow(dilemmas_info) # Number of implicative dilemmas + cnstr.labels <- character() cnstr.labels.left <- cnstr.labels.right <- cnstr.labels cnstr.id.left <- cnstr.id.right <- numeric() - + # Put all discrepant constructs to the right if (no_ids != 0) { for (v in seq_len(no_ids)) { - if (dilemmas_info$type.c1[v] == 'discrepant') { - cnstr.labels.left[v] = dilemmas_info[v, "name.c2"] - cnstr.labels.right[v] = dilemmas_info[v, "name.c1"] - cnstr.id.left[v] = dilemmas_info[v, "c2"] - cnstr.id.right[v] = dilemmas_info[v, "c1"] - } - else { - cnstr.labels.left[v] = dilemmas_info[v, "name.c1"] - cnstr.labels.right[v] = dilemmas_info[v, "name.c2"] - cnstr.id.left[v] = dilemmas_info[v, "c1"] - cnstr.id.right[v] = dilemmas_info[v, "c2"] + if (dilemmas_info$type.c1[v] == "discrepant") { + cnstr.labels.left[v] <- dilemmas_info[v, "name.c2"] + cnstr.labels.right[v] <- dilemmas_info[v, "name.c1"] + cnstr.id.left[v] <- dilemmas_info[v, "c2"] + cnstr.id.right[v] <- dilemmas_info[v, "c1"] + } else { + cnstr.labels.left[v] <- dilemmas_info[v, "name.c1"] + cnstr.labels.right[v] <- dilemmas_info[v, "name.c2"] + cnstr.id.left[v] <- dilemmas_info[v, "c1"] + cnstr.id.right[v] <- dilemmas_info[v, "c2"] } } } - + ## 4: reordered dilemma output cnstr.labels.left <- paste0(cnstr.id.left, ". ", cnstr.labels.left) cnstr.labels.right <- paste0(cnstr.id.right, ". ", cnstr.labels.right) @@ -2017,32 +2124,33 @@ indexDilemmaInternal <- function(x, self, ideal, cnstr.labels.left <- character() cnstr.labels.right <- character() } - dilemmas_df <- data.frame(cnstr.id.left, cnstr.labels.left, - cnstr.id.right, cnstr.labels.right, - Rtot = dilemmas_info[,3], RexSI = dilemmas_info[,4], - stringsAsFactors = FALSE) + dilemmas_df <- data.frame(cnstr.id.left, cnstr.labels.left, + cnstr.id.right, cnstr.labels.right, + Rtot = dilemmas_info[, 3], RexSI = dilemmas_info[, 4], + stringsAsFactors = FALSE + ) # colnames(dilemmas_df) = c('Self - Not self', 'Rtot', 'Self - Ideal', 'RexSI') - colnames(dilemmas_df) = c("id_c", "Congruent", "id_d", "Discrepant", 'R', 'RexSI') - + colnames(dilemmas_df) <- c("id_c", "Congruent", "id_d", "Discrepant", "R", "RexSI") + ## 5: measures - d = no_ids - r <- dilemmas_df$R # correlations between ID pairs - + d <- no_ids + r <- dilemmas_df$R # correlations between ID pairs + # PID # percentage of IDs over total number of possible constructs pairs - pid = d / nrow(comb) - + pid <- d / nrow(comb) + # IID - # Intensity of the implicative dilemma (IID), quotient of the number of + # Intensity of the implicative dilemma (IID), quotient of the number of # constructs by the probability of finding implicative dilemmas given the matrix size. # iid = sqrt(sum(r^2)) / d * 100 # "correct" version from paper - iid = sum(r) / d * 100 # version as in Gridcor (not as in paper) - + iid <- sum(r) / d * 100 # version as in Gridcor (not as in paper) + # PICID # proportion of the intensity of constructs of implicative dilemmas # picid = sqrt(sum(r^2)) / n_construct_pairs * 100 # "correct" version from paper - picid = sum(r) / n_construct_pairs * 100 # version in Gridcor (not as in paper) - + picid <- sum(r) / n_construct_pairs * 100 # version in Gridcor (not as in paper) + # gather measures measures <- list( iid = iid, @@ -2053,46 +2161,47 @@ indexDilemmaInternal <- function(x, self, ideal, # REALIGEND GRID ii_swap <- which(needs.to.invert) x_aligned <- swapPoles(x, pos = ii_swap) - + # CONSTRUCTS INVOLVED in IDS - i_involved <- union(dilemmas_info$c1, dilemmas_info$c2) - + i_involved <- union(dilemmas_info$c1, dilemmas_info$c2) + # indexDilemma object - l <- list(no_ids = no_ids, - n_construct_pairs = n_construct_pairs, # = factorial(n) / (2*factorial(n - 2)) - self = self, - reversed = which(needs.to.invert), - constructs_involved = i_involved, - ideal = ideal, - elements = enames, - diff.discrepant = diff.discrepant, - diff.congruent = diff.congruent, - exclude = exclude, - r.min = r.min, - diff.mode = diff.mode, - midpoint = midpoint, - measures = measures, - # dataframes - construct_classification = construct_classification, # discrepant / congruent - dilemmas_info = dilemmas_info, - dilemmas_df = dilemmas_df, # table with dilemmas and correlations - grid_aligned = x_aligned - ) + l <- list( + no_ids = no_ids, + n_construct_pairs = n_construct_pairs, # = factorial(n) / (2*factorial(n - 2)) + self = self, + reversed = which(needs.to.invert), + constructs_involved = i_involved, + ideal = ideal, + elements = enames, + diff.discrepant = diff.discrepant, + diff.congruent = diff.congruent, + exclude = exclude, + r.min = r.min, + diff.mode = diff.mode, + midpoint = midpoint, + measures = measures, + # dataframes + construct_classification = construct_classification, # discrepant / congruent + dilemmas_info = dilemmas_info, + dilemmas_df = dilemmas_df, # table with dilemmas and correlations + grid_aligned = x_aligned + ) class(l) <- c("indexDilemma", class(l)) l } #' Print method for class indexDilemma -#' +#' #' @param x Object of class indexDilemma #' @param digits Numeric. Number of digits to round to (default is `2`). -#' @param output String with each letter indicating which parts of the output to print +#' @param output String with each letter indicating which parts of the output to print #' (default is `"OCD"`, order does not matter): #' `S` = Summary (Number of IDs, PID, etc.), #' `P` = Analysis parameters, -#' `C` = Construct classification table, -#' `D` = Implicative dilemmas table. +#' `C` = Construct classification table, +#' `D` = Implicative dilemmas table. #' @param ... Not evaluated. #' @method print indexDilemma #' @keywords internal @@ -2111,16 +2220,16 @@ print.indexDilemma <- function(x, digits = 2, output = "SPCD", ...) { exclude <- x$exclude midpoint <- x$midpoint dilemmas_df <- x$dilemmas_df - + # measures pid <- x$measures$pid iid <- x$measures$iid picid <- x$measures$picid - + cat("\n####################\n") cat("Implicative Dilemmas") cat("\n####################\n") - + ## Summary and Measures if (str_detect(output, "S")) { cat("\n-------------------------------------------------------------------------------") @@ -2132,17 +2241,17 @@ print.indexDilemma <- function(x, digits = 2, output = "SPCD", ...) { cat("\nPercentage of IDs (PID):", pid_perc, pid_no) cat("\nIntensity of IDs (IID):", round(iid, 1)) cat("\nProportion of the intensity of constructs of IDs (PICID):", round(picid, 1)) - } - + } + ## Parameters if (str_detect(output, "P")) { cat("\n\n-------------------------------------------------------------------------------") cat(bold("\n\nPARAMETERS:\n")) cat("\nSelf: Element No.", paste0(self, " = ", enames[self])) - cat("\nIdeal: Element No.", paste0(ideal, " = ", enames[ideal])) + cat("\nIdeal: Element No.", paste0(ideal, " = ", enames[ideal])) cat("\n\nCorrelation Criterion: >=", r.min) if (exclude) { - cat("\nNote: Correlation calculated excluding elements Self & Ideal") + cat("\nNote: Correlation calculated excluding elements Self & Ideal") } else { cat("\nNote: Correlation calculated including elements Self & Ideal\n") } @@ -2156,28 +2265,28 @@ print.indexDilemma <- function(x, digits = 2, output = "SPCD", ...) { cat("\nUsing Midpoint rating criterion") } } - #Extreme Criteria: - #Discrepant Difference: Self-Ideal greater than or equal to, Max Other-Self difference - #Congruent Difference: Self-Ideal less than or equal to, Min Other-Self difference + # Extreme Criteria: + # Discrepant Difference: Self-Ideal greater than or equal to, Max Other-Self difference + # Congruent Difference: Self-Ideal less than or equal to, Min Other-Self difference ## Classification of constructs: if (str_detect(output, "C")) { cat("\n\n-------------------------------------------------------------------------------") cat(bold("\n\nCLASSIFICATION OF CONSTRUCTS:\n")) cat(blue("\n Note: Constructs aligned so 'Self' corresponds to left pole\n\n")) - - # cat(paste0("\n Note: 'Self' corresponds to left pole ", + + # cat(paste0("\n Note: 'Self' corresponds to left pole ", # "unless score equals the midpoint (", midpoint, " = undecided)\n\n")) print(x$construct_classification) } - + ## Implicative Dilemmas: if (str_detect(output, "D")) { cat("\n-------------------------------------------------------------------------------") cat(bold("\n\nIMPLICATIVE DILEMMAS:\n")) cat(blue("\n Note: Congruent constructs on the left - Discrepant constructs on the right")) cat("\n\n") - + if (nrow(dilemmas_df) > 0) { dilemmas_df <- dilemmas_df %>% select(-id_c, -id_d) dilemmas_df$R <- round(dilemmas_df$R, digits) @@ -2211,16 +2320,16 @@ print.indexDilemma <- function(x, digits = 2, output = "SPCD", ...) { #' The detection of implicative dilemmas happens in two steps. First the constructs are classified as being 'congruent' #' or 'discrepant'. Secondly, the correlation between a congruent and discrepant construct pair is assessed if it is #' big enough to indicate an implication. -#' -#' **Classifying the construct** -#' +#' +#' **Classifying the construct** +#' #' To detect implicit dilemmas the construct pairs are first identified as 'congruent' or 'discrepant'. The assessment #' is based on the rating differences between the elements 'self' and 'ideal self'. A construct is 'congruent' if the #' construction of the 'self' and the preferred state (i.e. ideal self) are the same or similar. A construct is #' discrepant if the construction of the 'self' and the 'ideal' is dissimilar. #' #' There are two popular accepted methods to identify congruent and discrepant constructs: -#' +#' #' 1. "Scale Midpoint criterion" (cf. Grice 2008) #' 2. "Minimal and maximal score difference" (cf. Feixas & Saul, 2004) #' @@ -2251,13 +2360,13 @@ print.indexDilemma <- function(x, digits = 2, output = "SPCD", ...) { #' #' The values used to classify the constructs 'congruent' or 'discrepant' can be determined in several ways (cf. Bell, #' 2009): -#' +#' #' 1. They are set 'a priori'. #' 2. They are implicitly derived by taking into account the rating #' differences to the other constructs. (Not yet implemented) #' #' The value mode is determined via the argument `diff.mode`. -#' +#' #' If no 'a priori' criteria to determine whether the construct is congruent or discrepant is supplied as an argument, #' the values are chosen according to the range of the rating scale used. For the following scales the defaults are #' chosen as: @@ -2273,9 +2382,9 @@ print.indexDilemma <- function(x, digits = 2, output = "SPCD", ...) { #' | 1 2 3 4 5 6 7 8 | --> con: <=1 disc: >=5 | #' | 1 2 3 4 5 6 7 8 9 | --> con: <=2 disc: >=5 | #' | 1 2 3 4 5 6 7 8 9 10 | --> con: <=2 disc: >=6 | -#' -#' **Defining the correlations** -#' +#' +#' **Defining the correlations** +#' #' As the implications between constructs cannot be derived from a rating grid directly, the correlation between two #' constructs is used as an indicator for implication. A large correlation means that one construct pole implies the #' other. A small correlation indicates a lack of implication. The minimum criterion for a correlation to indicate @@ -2285,8 +2394,8 @@ print.indexDilemma <- function(x, digits = 2, output = "SPCD", ...) { #' e. self and ideal self) can be included (default) or excluded. The options will cause different correlations (see #' argument `exclude`). #' -#' **Example of an implicative dilemma** -#' +#' **Example of an implicative dilemma** +#' #' A depressive person considers herself as 'timid' and wished to change to the opposite pole she defines as #' 'extraverted'. This construct is called discrepant as the construction of the 'self' and the desired state (e.g. #' described by the 'ideal self') on this construct differ. The person also considers herself as 'sensitive' (preferred @@ -2322,10 +2431,10 @@ print.indexDilemma <- function(x, digits = 2, output = "SPCD", ...) { #' trimming is done. Trimming simply saves space when displaying the output. #' @param digits Numeric. Number of digits to round to (default is `2`). #' @param output The type of output to return. -#' +#' #' @author Mark Heckmann, Alejandro García, Diego Vitali #' @return List object of class `indexDilemma`, containing the result from the calculations. -#' @references +#' @references #' Bell, R. C. (2009). *Gridstat version 5 - A Program for Analyzing the Data of A Repertory Grid* #' (manual). University of Melbourne, Australia: Department of Psychology. #' @@ -2347,28 +2456,33 @@ print.indexDilemma <- function(x, digits = 2, output = "SPCD", ...) { #' @seealso [print.indexDilemma()], [plot.indexDilemma()] #' @export #' @example inst/examples/example-implicative-dilemmas.R -#' -indexDilemma <- function(x, self = 1, ideal = ncol(x), +#' +indexDilemma <- function(x, self = 1, ideal = ncol(x), diff.mode = 1, diff.congruent = NA, - diff.discrepant = NA, diff.poles = 1, + diff.discrepant = NA, diff.poles = 1, r.min = .35, exclude = FALSE, digits = 2, show = FALSE, output = 1, index = TRUE, trim = 20) { # automatic selection of a priori criteria sc <- getScale(x) - if (is.na(diff.congruent)) + if (is.na(diff.congruent)) { diff.congruent <- floor(diff(sc) * .25) - if (is.na(diff.discrepant)) - diff.discrepant <- ceiling(diff(sc) * .6) - + } + if (is.na(diff.discrepant)) { + diff.discrepant <- ceiling(diff(sc) * .6) + } + # detect dilemmas - res <- indexDilemmaInternal(x, self = self, ideal = ideal, - diff.mode = diff.mode, diff.congruent = diff.congruent, - diff.discrepant = diff.discrepant, diff.poles = diff.poles, - r.min = r.min, exclude = exclude, digits = digits, - index = index, trim = trim) - if (show) + res <- indexDilemmaInternal(x, + self = self, ideal = ideal, + diff.mode = diff.mode, diff.congruent = diff.congruent, + diff.discrepant = diff.discrepant, diff.poles = diff.poles, + r.min = r.min, exclude = exclude, digits = digits, + index = index, trim = trim + ) + if (show) { indexDilemmaShowCorrelationDistribution(x, self, ideal) - + } + res } @@ -2376,11 +2490,11 @@ indexDilemma <- function(x, self = 1, ideal = ncol(x), #' Plot method for indexDilemma (network graph) #' -#' Produces a network graph using of the detected implicative dilemmas using the +#' Produces a network graph using of the detected implicative dilemmas using the #' `igraph` package. #' #' @param x Object returned by `indexDilemma`. -#' @param layout Name of layout. One of `rows`, `circle`, `star`, or `nicely` or a +#' @param layout Name of layout. One of `rows`, `circle`, `star`, or `nicely` or a #' `igraph` layout function. #' @param both.poles Show both construct poles? (default `TRUE`). If `FALSE` #' only the poles corresponding to the implied undesired changes are shown. @@ -2388,7 +2502,7 @@ indexDilemma <- function(x, self = 1, ideal = ncol(x), #' @param node.size Size of nodes (default `50`). #' @param node.text.cex Text size of construct labels. #' @param node.label.color Color of construct labels. -#' @param node.color.discrepant,node.color.congruent Color of discrepant and congruent constructs nodes. +#' @param node.color.discrepant,node.color.congruent Color of discrepant and congruent constructs nodes. #' @param edge.label.color,edge.label.cex Color and size of correlation labels. #' @param edge.color,edge.arrow.size Color and Size of arrow. #' @param edge.lty Linetype of arrow. @@ -2396,78 +2510,81 @@ indexDilemma <- function(x, self = 1, ideal = ncol(x), #' @export #' plot.indexDilemma <- function( - x, - layout = "rows", - both.poles = TRUE, - node.size = 50, - node.text.cex = 1, - node.label.color = "black", - node.color.discrepant = "darkolivegreen3", - node.color.congruent = "lightcoral", - edge.label.color = grey(.4), - edge.label.cex = 1, - edge.digits = 2, - edge.arrow.size = .5, - edge.color = grey(.6), - edge.lty = 2, - ... -) { - id = x # renamed from 'id' to 'x' to match arg in print generic - + x, + layout = "rows", + both.poles = TRUE, + node.size = 50, + node.text.cex = 1, + node.label.color = "black", + node.color.discrepant = "darkolivegreen3", + node.color.congruent = "lightcoral", + edge.label.color = grey(.4), + edge.label.cex = 1, + edge.digits = 2, + edge.arrow.size = .5, + edge.color = grey(.6), + edge.lty = 2, + ...) { + id <- x # renamed from 'id' to 'x' to match arg in print generic + # response in case no dilemmas were found if (id$no_ids == 0) { plot.new() text(.5, .5, "No implicative dilemmas detected") return(invisible(NULL)) } - + # rename args vertex.size <- node.size vertex.label.cex <- node.text.cex - + # get relevant data from indexDilemma object - x <- id$grid + x <- id$grid r.min <- id$r.min dilemmas_df <- id$dilemmas_df x <- id$grid_aligned i_involved <- id$constructs_involved # constructs involved in IDs R <- constructCor(x, trim = NA) if (both.poles) { - vertex_labels <- rownames(R) + vertex_labels <- rownames(R) } else { vertex_labels <- constructs(x)$rightpole } vertex_labels <- vertex_labels[i_involved] %>% str_wrap(width = 15) - + # Create directed indicator matrix. Only one direction, i.e. from # discrepant to congruent construct = negative implication # direction in matrix from row (discrepant) to column (congruent) K <- R - K[,] <- 0 + K[, ] <- 0 for (i in 1L:nrow(dilemmas_df)) { - K[ dilemmas_df$id_d[i], dilemmas_df$id_c[i] ] <- 1 # row -> column + K[dilemmas_df$id_d[i], dilemmas_df$id_c[i]] <- 1 # row -> column } - edge_labels <- R[K == 1] %>% round(edge.digits) # round correlations - + edge_labels <- R[K == 1] %>% round(edge.digits) # round correlations + # remove non-ID constructs W_red <- K[i_involved, i_involved] - g <- igraph::graph_from_adjacency_matrix(W_red, diag = FALSE, - mode = "directed", weighted = TRUE) - vertex_colors <- dplyr::recode(id$construct_classification$Classification, - "congruent" = node.color.congruent, - "discrepant" = node.color.discrepant, - "neither" = "grey") + g <- igraph::graph_from_adjacency_matrix(W_red, + diag = FALSE, + mode = "directed", weighted = TRUE + ) + vertex_colors <- dplyr::recode(id$construct_classification$Classification, + "congruent" = node.color.congruent, + "discrepant" = node.color.discrepant, + "neither" = "grey" + ) vertex_colors <- vertex_colors[i_involved] igraph::V(g)$color <- vertex_colors - + # type vector for bipartite layout (boolean) - vertex_bipart_type <- dplyr::recode(id$construct_classification$Classification, - "congruent" = T, - "discrepant" = F, - "neither" = NA) + vertex_bipart_type <- dplyr::recode(id$construct_classification$Classification, + "congruent" = T, + "discrepant" = F, + "neither" = NA + ) vertex_bipart_type <- vertex_bipart_type[i_involved] igraph::V(g)$type <- vertex_bipart_type - + # simplified selection among sensible igraph layouts if (is.function(layout)) { layout <- layout @@ -2479,80 +2596,77 @@ plot.indexDilemma <- function( layout <- igraph::layout_as_bipartite } else { layout <- igraph::layout_nicely - } - - old_par <- par(oma = c(0,0,0,0), mar = c(0,0,0,0)) + } + + old_par <- par(oma = c(0, 0, 0, 0), mar = c(0, 0, 0, 0)) on.exit(old_par) - igraph::plot.igraph(g, frame = FALSE, ylim = c(-1.3, 1), - layout = layout, rescale = TRUE, - edge.curved = FALSE, - edge.arrow.size = edge.arrow.size, - edge.label.cex = edge.label.cex, - edge.lty = edge.lty, - edge.width = 1.5, - edge.label = edge_labels, - edge.color = edge.color, - edge.label.color = edge.label.color, - vertex.size = vertex.size, - vertex.size2 = vertex.size, - vertex.label = vertex_labels, - vertex.label.color = node.label.color, - vertex.label.cex = vertex.label.cex, - vertex.label.family = "sans", - vertex.color = vertex_colors, - vertex.frame.color = grey(.5)) - legend(x = "bottom", - legend = c("a desired change on 'discrepant' construct", "implies an undesired change on 'congruent' construct"), - bty = "n", cex = 1, inset = c(0, 0), - xjust = .5, box.col = FALSE, horiz = FALSE, yjust = 1, - fill = c(node.color.discrepant, node.color.congruent)) + igraph::plot.igraph(g, + frame = FALSE, ylim = c(-1.3, 1), + layout = layout, rescale = TRUE, + edge.curved = FALSE, + edge.arrow.size = edge.arrow.size, + edge.label.cex = edge.label.cex, + edge.lty = edge.lty, + edge.width = 1.5, + edge.label = edge_labels, + edge.color = edge.color, + edge.label.color = edge.label.color, + vertex.size = vertex.size, + vertex.size2 = vertex.size, + vertex.label = vertex_labels, + vertex.label.color = node.label.color, + vertex.label.cex = vertex.label.cex, + vertex.label.family = "sans", + vertex.color = vertex_colors, + vertex.frame.color = grey(.5) + ) + legend( + x = "bottom", + legend = c("a desired change on 'discrepant' construct", "implies an undesired change on 'congruent' construct"), + bty = "n", cex = 1, inset = c(0, 0), + xjust = .5, box.col = FALSE, horiz = FALSE, yjust = 1, + fill = c(node.color.discrepant, node.color.congruent) + ) } -# dilemmaViz <- function(x) +# dilemmaViz <- function(x) # { - # self <- id$self - # ideal <- id$ideal - # i <- 1 - # id$dilemmas_info - # - # r <- ratings(x) - # r_self <- r[i, self] - # r_ideal <- r[i, ideal] - # - # r = .39 1 2 3 4 5 6 7 - # congruent: jayn jnay inay |SI-----------------------| jayn jnay inay - # discrepant: sxknsx kmsx |S----------I-------------| iisxsxsxsxsx - # - # library(crayon) - # - # +# self <- id$self +# ideal <- id$ideal +# i <- 1 +# id$dilemmas_info +# +# r <- ratings(x) +# r_self <- r[i, self] +# r_ideal <- r[i, ideal] +# +# r = .39 1 2 3 4 5 6 7 +# congruent: jayn jnay inay |SI-----------------------| jayn jnay inay +# discrepant: sxknsx kmsx |S----------I-------------| iisxsxsxsxsx +# +# library(crayon) +# +# # } -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// # Pemutation test to test if grid is random. -# "The null hypothesis [is] that a particular grid -# is indis- tinguishable from an array of random numbers" +# "The null hypothesis [is] that a particular grid +# is indis- tinguishable from an array of random numbers" # (Slater, 1976, p. 129). # # randomTest <- function(x){ # x # } # permutationTest -# Hartmann 1992: -# To illustrate: If a person decided to produce a nonsense grid, -# the most appropriate way to achieve this goal would be to rate -#(rank) the elements randomly. The variation of the elements on -# the con- structs would lack any psychological sense. Every +# Hartmann 1992: +# To illustrate: If a person decided to produce a nonsense grid, +# the most appropriate way to achieve this goal would be to rate +# (rank) the elements randomly. The variation of the elements on +# the con- structs would lack any psychological sense. Every # statistical analysis should then lead to noninterpretable results. - - - - - - - diff --git a/R/onair.r b/R/onair.r index 7df08ed0..5db13ffd 100644 --- a/R/onair.r +++ b/R/onair.r @@ -1,21 +1,19 @@ # convert grid file to string -onAirQuery <- function(x, domain="onair.openrepgrid.org") -{ - #if (local) - #str <- paste0("http://localhost:8100/?grid=", get.query) +onAirQuery <- function(x, domain = "onair.openrepgrid.org") { + # if (local) + # str <- paste0("http://localhost:8100/?grid=", get.query) file <- paste0(tempfile(), ".txt") saveAsTxt(x, file) l <- readLines(file) - get.query <- paste(l[-(1:3)], collapse="\n") + get.query <- paste(l[-(1:3)], collapse = "\n") paste0("http://", domain, "/?grid=", get.query) } # onAirQuery(boeker) -onAir <- function(x) -{ +onAir <- function(x) { query <- onAirQuery(x) - browseURL(query) + browseURL(query) } diff --git a/R/openrepgrid.r b/R/openrepgrid.r index 6e0f4170..107e49e5 100644 --- a/R/openrepgrid.r +++ b/R/openrepgrid.r @@ -1,4 +1,3 @@ - ############################### Package description ########################### #' `OpenRepGrid`: an R package for the analysis of repertory grids. @@ -46,16 +45,16 @@ ############################# Package overview ############################## -#' \pkg{OpenRepGrid}: Annotated overview of package functions. +#' \pkg{OpenRepGrid}: Annotated overview of package functions. #' #' This documentation page contains an overview over the package functions #' ordered by topics. The best place to start learning OpenRepGrid will #' be the package website though. -#' -#' @section Functions sorted by topic: -#' -#' **Manipulating grids** \cr -#' +#' +#' @section Functions sorted by topic: +#' +#' **Manipulating grids** \cr +#' #' \tabular{ll}{ #' [left()] \tab Move construct(s) to the left \cr #' [right()] \tab Move construct(s) to the right \cr @@ -63,8 +62,8 @@ #' [down()] \tab Move construct(s) downwards \cr #' } #' -#' **Loading and saving data** \cr -#' +#' **Loading and saving data** \cr +#' #' \tabular{ll}{ #' [importGridcor()] \tab Import GRIDCOR data files \cr #' [importGridstat()] \tab Import Gridstat data files \cr @@ -74,21 +73,21 @@ #' \tab \cr #' [saveAsTxt()] \tab Save grid in a text file (txt) \cr #' } -#' -#' **Analyzing constructs** \cr -#' +#' +#' **Analyzing constructs** \cr +#' #' Descriptive statistics of constructs #' Construct correlations #' distance #' Root mean square of inter-construct correlations -#' Somers' D -#' Principal component analysis (PCA) of construct correlation matrix +#' Somers' D +#' Principal component analysis (PCA) of construct correlation matrix #' Cluster analysis of constructs -#' -#' **Analyzing elements** \cr -#' -#' **Visual representation** \cr -#' +#' +#' **Analyzing elements** \cr +#' +#' **Visual representation** \cr +#' #' \tabular{ll}{ #' *Bertin plots* \tab \cr #' \tab \cr @@ -111,10 +110,10 @@ #' [biplotSlater3d()] \tab Draw the Slater's INGRID biplot in rgl (3D device) \cr #' \tab \cr #' [biplotSimple()] \tab A graphically unsophisticated version of a biplot \cr -#' } -#' +#' } +#' #' **Index measures** \cr -#' +#' #' \tabular{ll}{ #' [indexConflict1()] \tab Conflict measure for grids (Slade & Sheehan, 1979) based on correlations \cr #' [indexConflict2()] \tab Conflict measure for grids (Bassler et al., 1992) based on correlations \cr @@ -127,92 +126,92 @@ #' [indexBias()] \tab Calculate 'bias' of grid as defined by Slater (1977) \cr #' [indexVariability()] \tab Calculate 'variability' of a grid as defined by Slater (1977) \cr #' } -#' +#' #' **Special features** \cr -#' +#' #' \tabular{ll}{ #' [alignByIdeal()] \tab Align constructs using the ideal element to gain pole preferences \cr #' [alignByLoadings()] \tab Align constructs by loadings on first principal component \cr #' [reorder2d()] \tab Order grid by angles between construct and/or elements in 2D \cr #' } -#' +#' #' @section Settings: -#' -#' \pkg{OpenRepGrid} uses several default settings e.g. to determine +#' +#' \pkg{OpenRepGrid} uses several default settings e.g. to determine #' how many construct characters to display by default when displaying a grid. #' The function `settings` can be used to show and change these settings. #' Also it is possible to store the settings to a file and load the settings #' file to restore the settings. -#' +#' #' \tabular{ll}{ #' [settings()] \tab Show and modify global settings for OpenRepGrid \cr #' [settingsSave()] \tab Save OpenRepGrid settings to file \cr #' [settingsLoad()] \tab Load OpenRepGrid settings from file\cr #' } -#' +#' #' @section Grid datasets: -#' -#' \pkg{OpenRepGrid} already contains some ready to use grid data sets. Most of -#' the datasets are taken from the literature. To output the data simply type +#' +#' \pkg{OpenRepGrid} already contains some ready to use grid data sets. Most of +#' the datasets are taken from the literature. To output the data simply type #' Type the name of the dataset to the console and press enter. \cr -#' +#' #' *Single grids* \cr -#' +#' #' \tabular{ll}{ -#' [bell2010()] \tab Grid data from a study by Haritos et al. (2004) -#' on role titles; used for demonstration of +#' [bell2010()] \tab Grid data from a study by Haritos et al. (2004) +#' on role titles; used for demonstration of #' construct alignment in Bell (2010, p. 46). \cr -#' [bellmcgorry1992()] \tab Grid from a psychotic patient used in Bell -#' (1997, p. 6). Data originated from a study +#' [bellmcgorry1992()] \tab Grid from a psychotic patient used in Bell +#' (1997, p. 6). Data originated from a study #' by Bell and McGorry (1992). \cr -#' [boeker()] \tab Grid from seventeen year old female schizophrenic -#' patient undergoing last stage of psychoanalytically +#' [boeker()] \tab Grid from seventeen year old female schizophrenic +#' patient undergoing last stage of psychoanalytically #' oriented psychotherapy (Boeker, 1996, p. 163). \cr -#' [fbb2003()] \tab Dataset used in *A manual for Repertory Grid +#' [fbb2003()] \tab Dataset used in *A manual for Repertory Grid #' Technique* (Fransella, Bell, & Bannister, 2003b, p. 60). \cr -#' [feixas2004()] \tab Grid from a 22 year old Spanish girl suffering +#' [feixas2004()] \tab Grid from a 22 year old Spanish girl suffering #' self-worth problems (Feixas & Saul, 2004, p. 77). \cr -#' [mackay1992()] \tab Dataset *Grid C* used in Mackay's paper on inter-element +#' [mackay1992()] \tab Dataset *Grid C* used in Mackay's paper on inter-element #' correlation (1992, p. 65). \cr -#' [leach2001a()], [leach2001b()] \tab Pre- (a) and post-therapy (b) dataset from -#' sexual child abuse survivor (Leach, Freshwater, +#' [leach2001a()], [leach2001b()] \tab Pre- (a) and post-therapy (b) dataset from +#' sexual child abuse survivor (Leach, Freshwater, #' Aldridge, & Sunderland, 2001, p. 227). \cr -#' [raeithel()] \tab Grid data to demonstrate the use of Bertin diagrams -#' (Raeithel, 1998, p. 223). The context of its +#' [raeithel()] \tab Grid data to demonstrate the use of Bertin diagrams +#' (Raeithel, 1998, p. 223). The context of its #' administration is unknown. \cr #' [slater1977a()] \tab Drug addict grid dataset from (Slater, 1977, p. 32). \cr -#' [slater1977b()] \tab Grid dataset (ranked) from a seventeen year old -#' female psychiatric patient (Slater, 1977, p. 110) -#' showing depression, anxiety and self-mutilation. +#' [slater1977b()] \tab Grid dataset (ranked) from a seventeen year old +#' female psychiatric patient (Slater, 1977, p. 110) +#' showing depression, anxiety and self-mutilation. #' The data was originally reported by Watson (1970).\cr #' } -#' +#' #' *Multiple grids* \cr -#' -#' NOT YET AVAILABLE \cr -#' -#' +#' +#' NOT YET AVAILABLE \cr +#' +#' #' @section Functions for developers: -#' +#' #' \pkg{OpenRepGrid}: internal functions overview for developers. \cr -#' -#' Below you find a guide for developers: these functions are usually +#' +#' Below you find a guide for developers: these functions are usually #' not needed by the casual user. The internal functions have a twofold goal -#' 1) to provide means for advanced numerical grid analysis and 2) +#' 1) to provide means for advanced numerical grid analysis and 2) #' to facilitate function development. The function for these purposes #' are internal, i.e. they are not visible in the package documentation. #' Nonetheless they do have a documentation that #' can be accesses in the same way as for other functions. #' More in the details section. -#' +#' #' **Functions for advanced grid analysis** \cr -#' -#' The package provides functions to facilitate numerical research for grids. -#' These comprise the generation of random data, permutation of grids etc. -#' to facilitate Monte Carlo simulations, batch analysis of grids and other methods. -#' With R as an underlying framework, the results of grid analysis easily lend -#' themselves to further statistical processing and analysis within R. -#' This is one of the central advantages for researchers compared to other +#' +#' The package provides functions to facilitate numerical research for grids. +#' These comprise the generation of random data, permutation of grids etc. +#' to facilitate Monte Carlo simulations, batch analysis of grids and other methods. +#' With R as an underlying framework, the results of grid analysis easily lend +#' themselves to further statistical processing and analysis within R. +#' This is one of the central advantages for researchers compared to other #' standard grid software. The following table lists several functions for these purposes. #' #' \tabular{ll}{ @@ -224,14 +223,14 @@ #' } #' #' **Modules for function development** \cr -#' -#' Beside the advanced analysis feature the developer's functions comprise -#' low-level modules to create new functions for grid analysis. -#' Though the internal structure of a repgrid object in R is simple -#' (type e.g. `str(bell2010, 2)` to get an impression), it is convenient -#' to not have to deal with access on this level. Several function like e.g. -#' `getElementNames` are convenient wrappers that perform standard tasks -#' needed when implementing new functions. The following table lists several +#' +#' Beside the advanced analysis feature the developer's functions comprise +#' low-level modules to create new functions for grid analysis. +#' Though the internal structure of a repgrid object in R is simple +#' (type e.g. `str(bell2010, 2)` to get an impression), it is convenient +#' to not have to deal with access on this level. Several function like e.g. +#' `getElementNames` are convenient wrappers that perform standard tasks +#' needed when implementing new functions. The following table lists several #' functions for these purposes. #' #' \tabular{ll}{ @@ -254,12 +253,12 @@ #' [importTxtInternal()] \tab \cr #' } #' -#' @author Current members of the \pkg{OpenRepGrid} development team: Mark Heckmann. +#' @author Current members of the \pkg{OpenRepGrid} development team: Mark Heckmann. #' Everyone who is interested in developing the package is invited to join. #' #' The \pkg{OpenRepGrid} package development is hosted on github (). #' The github site provides information and allows to file bug reports or feature requests. -#' Bug reports can also be emailed to the package maintainer or issued on +#' Bug reports can also be emailed to the package maintainer or issued on #' under section *Suggestions/Issues*. #' The package maintainer is Mark Heckmann . #' @@ -268,5 +267,3 @@ #' @docType package #' NULL - - diff --git a/R/perturbate.R b/R/perturbate.R index 6e8e3319..4042b874 100644 --- a/R/perturbate.R +++ b/R/perturbate.R @@ -1,63 +1,62 @@ - -## perturbate grid data - - -#' Perturbate grid ratings -#' -#' Randomly subtract or add an amount to a proportion of the grid ratings. This -#' emulates randomness during the rating process, producing a grid which might -#' also have resulted. -#' @param x A `repgrid` object. -#' @param n Number of perturbated grid to generate. -#' @param prop The proportion of ratings to be perturbated. -#' @param amount The amount set of possible perturbations. Will depend on scale -#' range. Usually {-1, 1} are reasonable settings -#' @param prob Probability for each amount to occur. -#' @export -#' @example inst/examples/example-perturbate.R -#' @rdname perturbate -#' -perturbate <- function(x, prop = .1, amount = c(-1, 1), prob = c(.5, .5)) -{ - if (!inherits(x, "repgrid")) - stop("Object must be of class 'repgrid'") - - if (length(amount) != length(prob)) - stop("Length of 'amount' and 'prob' must be the same. ", - "Each entry in amount must have a corresponding prob value.", call. = FALSE) - - sc <- getScale(x) # min, max of rating scale - smin <- sc[1] - smax <- sc[2] - r <- ratings(x) - N <- length(r) - n_sample <- floor(prop * N) - ii <- sample(seq_len(N), size = n_sample, replace = FALSE) - - # perturbate grid rating by given amounts and probablity for each amount. - # Values lower or higher thahn scale range are set back to min and max of scale range. - perturbations <- sample(amount, size = n_sample, replace = TRUE, prob = prob) - new_values <- r[ii] + perturbations - new_values <- ifelse(new_values < smin, smin, new_values) - new_values <- ifelse(new_values > smax, smax, new_values) - r[ii] <- new_values - ratings(x) <- r - x -} - - -#' @export -#' @rdname perturbate -#' -grids_perturbate <- function(x, n = 10, prop = .1, amount = c(-1, 1), prob = c(.5, .5)) -{ - l <- replicate(n, { - perturbate(x, prop = prop, amount = amount, prob = prob) - }, simplify = FALSE) - as.gridlist(l) -} - - - - - +## perturbate grid data + + +#' Perturbate grid ratings +#' +#' Randomly subtract or add an amount to a proportion of the grid ratings. This +#' emulates randomness during the rating process, producing a grid which might +#' also have resulted. +#' @param x A `repgrid` object. +#' @param n Number of perturbated grid to generate. +#' @param prop The proportion of ratings to be perturbated. +#' @param amount The amount set of possible perturbations. Will depend on scale +#' range. Usually {-1, 1} are reasonable settings +#' @param prob Probability for each amount to occur. +#' @export +#' @example inst/examples/example-perturbate.R +#' @rdname perturbate +#' +perturbate <- function(x, prop = .1, amount = c(-1, 1), prob = c(.5, .5)) { + if (!inherits(x, "repgrid")) { + stop("Object must be of class 'repgrid'") + } + + if (length(amount) != length(prob)) { + stop("Length of 'amount' and 'prob' must be the same. ", + "Each entry in amount must have a corresponding prob value.", + call. = FALSE + ) + } + + sc <- getScale(x) # min, max of rating scale + smin <- sc[1] + smax <- sc[2] + r <- ratings(x) + N <- length(r) + n_sample <- floor(prop * N) + ii <- sample(seq_len(N), size = n_sample, replace = FALSE) + + # perturbate grid rating by given amounts and probablity for each amount. + # Values lower or higher thahn scale range are set back to min and max of scale range. + perturbations <- sample(amount, size = n_sample, replace = TRUE, prob = prob) + new_values <- r[ii] + perturbations + new_values <- ifelse(new_values < smin, smin, new_values) + new_values <- ifelse(new_values > smax, smax, new_values) + r[ii] <- new_values + ratings(x) <- r + x +} + + +#' @export +#' @rdname perturbate +#' +grids_perturbate <- function(x, n = 10, prop = .1, amount = c(-1, 1), prob = c(.5, .5)) { + l <- replicate(n, + { + perturbate(x, prop = prop, amount = amount, prob = prob) + }, + simplify = FALSE + ) + as.gridlist(l) +} diff --git a/R/repgrid-basicops.r b/R/repgrid-basicops.r index ce11b1ec..dd29a5ac 100644 --- a/R/repgrid-basicops.r +++ b/R/repgrid-basicops.r @@ -1,9 +1,9 @@ #-------------------------------------------------------------# -# basic operations on repgrid objects # +# basic operations on repgrid objects # #-------------------------------------------------------------# -#' Test if object has class repgrid +#' Test if object has class repgrid #' @param x Any object. #' @export is.repgrid <- function(x) { @@ -17,10 +17,10 @@ is.repgrid <- function(x) { #' @export #' @keywords internal #' -stop_if_not_is_repgrid <- function(x, name = "x") -{ - if (!is.repgrid(x)) +stop_if_not_is_repgrid <- function(x, name = "x") { + if (!is.repgrid(x)) { stop("Object '", name, "' must have class 'repgrid'", call. = FALSE) + } } @@ -30,13 +30,12 @@ stop_if_not_is_repgrid <- function(x, name = "x") #' @export #' @keywords internal #' -stop_if_not_0_1_ratings_only <- function(x, name = "x") -{ +stop_if_not_0_1_ratings_only <- function(x, name = "x") { r <- ratings(x) ii <- r %in% 0:1 check <- all(ii) if (!check) { - other_values <- sort(unique(r[!ii])) + other_values <- sort(unique(r[!ii])) msg <- paste(other_values, collapse = ",") stop("Object '", name, "' must have 0/1 ratings only. Also found: ", msg, call. = FALSE) } @@ -48,14 +47,15 @@ stop_if_not_0_1_ratings_only <- function(x, name = "x") #' @export #' @keywords internal #' -stop_if_scale_not_defined <- function(x) -{ +stop_if_scale_not_defined <- function(x) { stop_if_not_is_repgrid(x, name) - - if (identical(x@scale$min, NA) | identical(x@scale$min, NULL)) + + if (identical(x@scale$min, NA) | identical(x@scale$min, NULL)) { stop("No min value for the rating scale defined. To define the scale use setScale().") - if (identical(x@scale$max, NA) | identical(x@scale$max, NULL)) + } + if (identical(x@scale$max, NA) | identical(x@scale$max, NULL)) { stop("No max value for the rating scale defined. To define the scale use setScale().") + } } @@ -65,7 +65,7 @@ stop_if_scale_not_defined <- function(x) # overloading primitive generic "[" getter # "[" is supposed to function like always, i.e. positive integers for selection # or reordering negative integers for deletion. These cannot be mixed -# TODO: ?keep single entry as row selection. Normally its column selection e.g. +# TODO: ?keep single entry as row selection. Normally its column selection e.g. # in data frames. # aliases [,repgrid-method @@ -73,8 +73,8 @@ stop_if_scale_not_defined <- function(x) #' Extract parts of the repgrid object. #' -#' Methods for `"["`, i.e., subsetting of repgrid objects. -#' +#' Methods for `"["`, i.e., subsetting of repgrid objects. +#' #' @param x A `repgrid` object. #' @param i,j Row and column indices. #' @param ... Not evaluated. @@ -82,59 +82,73 @@ stop_if_scale_not_defined <- function(x) #' @rdname extract-methods #' @aliases [,repgrid-method #' @include repgrid.r -#' @examples -#' -#' x <- randomGrid() -#' x[1:4, ] -#' x[ , 1:3] -#' x[1:4,1:3] -#' x[1,1] -#' -setMethod("[", signature(x = "repgrid", i = "ANY", j="ANY"), - function (x, i, j, ..., drop) - { +#' @examples +#' +#' x <- randomGrid() +#' x[1:4, ] +#' x[, 1:3] +#' x[1:4, 1:3] +#' x[1, 1] +#' +setMethod( + "[", signature(x = "repgrid", i = "ANY", j = "ANY"), + function(x, i, j, ..., drop) { dots <- list(...) - if(length(dots)==0){ - layer <- seq_along(dim(x@ratings)[3]) # 1:3 - } else if(!is.numeric(dots[[1]])){ - stop("... must be numeric as it is third index for 3D-array.") - } else if(!any(dots[[1]] %in% 1:3)){ - stop("... must be an integer between from 1 to 3.") - } else { - layer <- dots[[1]] - } - if(missing(i)) - i <- seq_len(length(x@constructs)) - if(missing(j)) - j <- seq_len(length(x@elements)) - if(!is.numeric(c(i, j))) # check if i,j are numeric - stop("All index values must be numeric") - if(any(is.na(c(i, j)))) - stop("NA values are not allowed as indexes.") - if(!((all(i >=0 ) | all(i <= 0)) & (all(j >= 0) | all(j <= 0)))) # check if i and j are each only positive or only negative - stop("Negative and positive indexes for constructs/elements must not be mixed. ", - "A positive index will select an element/construct a negative one will delete it.") - if(any(i > length(x@constructs)) | any(i == 0)) # check if all indexes do not exceed numer of elements or constructs - stop("index for constructs is out of range. ", - "Index must not exceed the number of constructs or equal zero.") - if(any(j > length(x@elements)) | any(j == 0)) # check if all indexes do not exceed numer of elements or constructs - stop("index for elements is out of range. ", - "Index must not exceed the number of elements or equal zero.") - x@constructs <- x@constructs[i] - x@elements <- x@elements[j] - x@ratings <- x@ratings[i, j, layer, drop=FALSE] - x -}) - -# aliases [<-,repgrid-method + if (length(dots) == 0) { + layer <- seq_along(dim(x@ratings)[3]) # 1:3 + } else if (!is.numeric(dots[[1]])) { + stop("... must be numeric as it is third index for 3D-array.") + } else if (!any(dots[[1]] %in% 1:3)) { + stop("... must be an integer between from 1 to 3.") + } else { + layer <- dots[[1]] + } + if (missing(i)) { + i <- seq_len(length(x@constructs)) + } + if (missing(j)) { + j <- seq_len(length(x@elements)) + } + if (!is.numeric(c(i, j))) { # check if i,j are numeric + stop("All index values must be numeric") + } + if (any(is.na(c(i, j)))) { + stop("NA values are not allowed as indexes.") + } + if (!((all(i >= 0) | all(i <= 0)) & (all(j >= 0) | all(j <= 0)))) { # check if i and j are each only positive or only negative + stop( + "Negative and positive indexes for constructs/elements must not be mixed. ", + "A positive index will select an element/construct a negative one will delete it." + ) + } + if (any(i > length(x@constructs)) | any(i == 0)) { # check if all indexes do not exceed numer of elements or constructs + stop( + "index for constructs is out of range. ", + "Index must not exceed the number of constructs or equal zero." + ) + } + if (any(j > length(x@elements)) | any(j == 0)) { # check if all indexes do not exceed numer of elements or constructs + stop( + "index for elements is out of range. ", + "Index must not exceed the number of elements or equal zero." + ) + } + x@constructs <- x@constructs[i] + x@elements <- x@elements[j] + x@ratings <- x@ratings[i, j, layer, drop = FALSE] + x + } +) + +# aliases [<-,repgrid-method # docType methods -# overloading primitive generic "[<-" setter. +# overloading primitive generic "[<-" setter. # -#' Method for "<-" assignment of the repgrid ratings. +#' Method for "<-" assignment of the repgrid ratings. #' #' It should be possible to use it for ratings on all layers. -#' +#' #' @param x A `repgrid` object. #' @param i,j Row and column indices. #' @param value Numeric replacement value(s). @@ -143,66 +157,81 @@ setMethod("[", signature(x = "repgrid", i = "ANY", j="ANY"), #' @include repgrid.r #' @examples \dontrun{ #' x <- randomGrid() -#' x[1,1] <- 2 +#' x[1, 1] <- 2 #' x[1, ] <- 4 -#' x[ ,2] <- 3 -#' -#' # settings values outside defined rating scale +#' x[, 2] <- 3 +#' +#' # settings values outside defined rating scale #' # range throws an error -#' x[1,1] <- 999 -#' +#' x[1, 1] <- 999 +#' #' # removing scale range allows arbitary values to be set -#' x <- setScale(x, min = NA, max=NA) -#' x[1,1] <- 999 +#' x <- setScale(x, min = NA, max = NA) +#' x[1, 1] <- 999 #' } #' -setMethod("[<-", signature(x = "repgrid", i = "ANY", j="ANY", value="ANY"), - function (x, i, j, ..., value) - { +setMethod( + "[<-", signature(x = "repgrid", i = "ANY", j = "ANY", value = "ANY"), + function(x, i, j, ..., value) { dots <- list(...) - if(length(dots)==0){ + if (length(dots) == 0) { layer <- 1 - } else if(!is.numeric(dots[[1]])){ + } else if (!is.numeric(dots[[1]])) { stop("... must be numeric as it is third index for 3D-array") - } else if(!any(dots[[1]] %in% 1:3)){ + } else if (!any(dots[[1]] %in% 1:3)) { stop("... must be an integer between from 1 to 3") } else { layer <- dots[[1]] - } - if (missing(i)) - i <- seq_len(length(x@constructs)) - if (missing(j)) + } + if (missing(i)) { + i <- seq_len(length(x@constructs)) + } + if (missing(j)) { j <- seq_len(length(x@elements)) - if (!is.numeric(c(i,j))) # check if i,j are numeric + } + if (!is.numeric(c(i, j))) { # check if i,j are numeric stop("All index values must be numeric") - if (any(is.na(c(i,j)))) + } + if (any(is.na(c(i, j)))) { stop("NA values are not allowed as indexes") - if (!((all(i >= 0) | all(i <= 0)) & (all( j >= 0) | all(j <= 0)))) # check if i and j are each only positive or only negative - stop("Negative and positive indexes for constructs/elements must not be mixed.", - " A positive index will select an element/construct a negative one will delete it") - if (any(i > length(x@constructs)) | any(i == 0)) # check if all indexes do not exceed numer of elements or constructs + } + if (!((all(i >= 0) | all(i <= 0)) & (all(j >= 0) | all(j <= 0)))) { # check if i and j are each only positive or only negative + stop( + "Negative and positive indexes for constructs/elements must not be mixed.", + " A positive index will select an element/construct a negative one will delete it" + ) + } + if (any(i > length(x@constructs)) | any(i == 0)) { # check if all indexes do not exceed numer of elements or constructs stop("index for constructs is out of range.", " Index must not exceed the number of constructs or equal zero.") - if (any(j > length(x@elements)) | any(j == 0)) # check if all indexes do not exceed numer of elements or constructs - stop("index for elements is out of range. Index must not", - " exceed the number of elements or equal zero.") - + } + if (any(j > length(x@elements)) | any(j == 0)) { # check if all indexes do not exceed numer of elements or constructs + stop( + "index for elements is out of range. Index must not", + " exceed the number of elements or equal zero." + ) + } + # prevent values outside of scale range from being set s <- getScale(x) sn <- is.null(s) | any(is.na(s)) - if ( (!sn & (any(value < s[1]) | any(value > s[2])) ) ) + if ((!sn & (any(value < s[1]) | any(value > s[2])))) { stop("Setting values outside of defined scale range is not allowed.", - " Use 'getScale' to see and 'setScale' to define the scale range. ", call. = FALSE) - - x@ratings[i, j, layer] <- value + " Use 'getScale' to see and 'setScale' to define the scale range. ", + call. = FALSE + ) + } + + x@ratings[i, j, layer] <- value # to fill by rows - #as.vector(matrix(as.vector(value), ncol=length(x@elements), byrow=TRUE)) + # as.vector(matrix(as.vector(value), ncol=length(x@elements), byrow=TRUE)) # another idea to fill by rows by transposing the part of importance - # f <- t(d[1:3, 1:2]) - # f[,] <- 1:6 - # d[1:3, 1:2] <- t(f) - x -}) + # f <- t(d[1:3, 1:2]) + # f[,] <- 1:6 + # d[1:3, 1:2] <- t(f) + x + } +) ########################### GETTER AND SETTER ############################### @@ -213,39 +242,38 @@ setMethod("[<-", signature(x = "repgrid", i = "ANY", j="ANY", value="ANY"), #' @param x `repgrid` object. #' @param layer layer to be returned. #' @param names extract row and columns names (constructs and elements). -#' @param trim the number of characters a row or column name is trimmed to +#' @param trim the number of characters a row or column name is trimmed to #' (default is `10`). If `NA` no trimming is done. Trimming #' simply saves space when displaying the output. -#' @return a `matrix` +#' @return a `matrix` #' #' @export #' @keywords internal #' @examples \dontrun{ #' -#' getRatingLayer(bell2010) +#' getRatingLayer(bell2010) #' } #' -getRatingLayer <- function(x, layer=1, names=TRUE, trim=10) -{ - scores <- x@ratings[ , , layer, drop=FALSE] # select layer - rm <- apply(scores, 2 , I) # convert array to matrix +getRatingLayer <- function(x, layer = 1, names = TRUE, trim = 10) { + scores <- x@ratings[, , layer, drop = FALSE] # select layer + rm <- apply(scores, 2, I) # convert array to matrix if (names) { cnames.l <- constructs(x)$leftpole cnames.r <- constructs(x)$rightpole enames <- elements(x) - if (!is.na(trim)){ # trim names if prompted + if (!is.na(trim)) { # trim names if prompted cnames.l <- substr(cnames.l, 1, trim) cnames.r <- substr(cnames.r, 1, trim) enames <- substr(enames, 1, trim) - } - rownames(rm) <- paste(cnames.l, cnames.r, sep=" - ") - colnames(rm) <- enames + } + rownames(rm) <- paste(cnames.l, cnames.r, sep = " - ") + colnames(rm) <- enames } rm } -# 'ratings' function replaces 'getRatingLayer' +# 'ratings' function replaces 'getRatingLayer' # as it sounds simpler #' Extract ratings (wide or long format) @@ -262,51 +290,50 @@ getRatingLayer <- function(x, layer=1, names=TRUE, trim=10) #' @export #' @rdname ratings #' @seealso ``[<--method`` -#' @examples -#' +#' @examples +#' #' ## store Bell's dataset in x #' x <- bell2010 -#' +#' #' ## get ratings #' ratings(x) -#' -#' -#' ## replace ratings -#' -#' ratings(x)[1,1] <- 1 +#' +#' +#' ## replace ratings +#' +#' ratings(x)[1, 1] <- 1 #' # noet that this is even simpler using the repgrid object directly -#' x[1,1] <- 2 -#' -#' #replace several values -#' -#' ratings(x)[1,1:5] <- 1 -#' x[1,1:5] <- 2 # the same -#' -#' ratings(x)[1:3,5:6] <- matrix(5, 3, 2) -#' x[1:3,5:6] <- matrix(5, 3, 2) # the same -#' -#' +#' x[1, 1] <- 2 +#' +#' # replace several values +#' +#' ratings(x)[1, 1:5] <- 1 +#' x[1, 1:5] <- 2 # the same +#' +#' ratings(x)[1:3, 5:6] <- matrix(5, 3, 2) +#' x[1:3, 5:6] <- matrix(5, 3, 2) # the same +#' +#' #' ## ratings as dataframe in wide or long format -#' +#' #' ratings_df(x) #' ratings_df(x, long = TRUE) -#' -ratings <- function(x, names = TRUE, trim = 10) -{ +#' +ratings <- function(x, names = TRUE, trim = 10) { layer <- 1 # get first layer of ratings array. The other two are not used - scores <- x@ratings[ , , layer, drop=FALSE] # select layer - rm <- apply(scores, 2 , I) # convert array to matrix + scores <- x@ratings[, , layer, drop = FALSE] # select layer + rm <- apply(scores, 2, I) # convert array to matrix if (names) { cnames.l <- constructs(x)$leftpole cnames.r <- constructs(x)$rightpole enames <- elements(x) - if (!is.na(trim)){ # trim names if prompted + if (!is.na(trim)) { # trim names if prompted cnames.l <- substr(cnames.l, 1, trim) cnames.r <- substr(cnames.r, 1, trim) enames <- substr(enames, 1, trim) - } - rownames(rm) <- paste(cnames.l, cnames.r, sep=" - ") - colnames(rm) <- enames + } + rownames(rm) <- paste(cnames.l, cnames.r, sep = " - ") + colnames(rm) <- enames } rm } @@ -314,8 +341,7 @@ ratings <- function(x, names = TRUE, trim = 10) #' @export #' @rdname ratings -ratings_df <- function(x, long = FALSE, names = TRUE, trim = NA) -{ +ratings_df <- function(x, long = FALSE, names = TRUE, trim = NA) { r <- ratings(x, trim = trim, names = names) if (!names) { colnames(r) <- paste0("E", 1L:ncol(x)) @@ -327,7 +353,7 @@ ratings_df <- function(x, long = FALSE, names = TRUE, trim = NA) df <- cbind(ii, cn, r) rownames(df) <- NULL if (long) { - df <- tidyr::pivot_longer(df, cols = names(r), names_to = "element", values_to = "rating") + df <- tidyr::pivot_longer(df, cols = names(r), names_to = "element", values_to = "rating") } df } @@ -335,18 +361,18 @@ ratings_df <- function(x, long = FALSE, names = TRUE, trim = NA) #' @rdname ratings #' @export -`ratings<-` <- function(x, i, j, value) -{ +`ratings<-` <- function(x, i, j, value) { # check if x is a repgrid object - if (!inherits(x, "repgrid")) + if (!inherits(x, "repgrid")) { stop("Object x must be of class 'repgrid'.") - + } + # fet rating matrix and replace values r <- ratings(x) r[i, j] <- value - + # replace all ratings - x[,] <- r + x[, ] <- r x } @@ -361,12 +387,13 @@ ratings_df <- function(x, long = FALSE, names = TRUE, trim = NA) #' @keywords internal #' @examples \dontrun{ #' -#' getNoOfConstructs(bell2010) +#' getNoOfConstructs(bell2010) #' } #' -getNoOfConstructs <- function(x){ - if (!inherits(x, "repgrid")) # check if x is repgrid object +getNoOfConstructs <- function(x) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object stop("object x and y must be of class 'repgrid'") + } length(x@constructs) } @@ -374,25 +401,26 @@ getNoOfConstructs <- function(x){ #' Get number of elements #' #' @param x `repgrid` object -#' @return `numeric` +#' @return `numeric` #' #' @export #' @keywords internal #' @examples \dontrun{ #' -#' getNoOfElements(bell2010) +#' getNoOfElements(bell2010) #' } #' -getNoOfElements <- function(x){ - if (!inherits(x, "repgrid")) # check if x is repgrid object +getNoOfElements <- function(x) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object stop("object x and y must be of class 'repgrid'") + } length(x@elements) } -#' Set the scale range of a grid. +#' Set the scale range of a grid. #' -#' The scale must be known for certain +#' The scale must be known for certain #' operations, e.g. to swap the construct poles. If the user construes #' a grid he should make sure that the scale range is set correctly. #' @@ -401,37 +429,45 @@ getNoOfElements <- function(x){ #' @param max Maximal possible scale value for ratings. #' @param step Steps the scales uses (not yet in use). #' @param ... Not evaluated. -#' +#' #' @return `repgrid` object #' @export #' @examples \dontrun{ #' -#' x <- bell2010 -#' x <- setScale(x, 0, 8) # not set correctly -#' x -#' x <- setScale(x, 1, 7) # set correctly -#' x +#' x <- bell2010 +#' x <- setScale(x, 0, 8) # not set correctly +#' x +#' x <- setScale(x, 1, 7) # set correctly +#' x #' } #' -setScale <- function(x, min, max, step, ...){ # ... needes for makeRepgrid call - if(!inherits(x, "repgrid")) # check if x is repgrid object +setScale <- function(x, min, max, step, ...) { # ... needes for makeRepgrid call + if (!inherits(x, "repgrid")) { # check if x is repgrid object stop("Object x must be of class 'repgrid'") - if (!missing(min)){ - if (any(x@ratings < min, na.rm=TRUE)) # any rating value smaller than min? - stop("Some ratings are smaller than the min value you entered. ", - "The setting of the min value in the grid was not performed. ", - "Please check the ratings or choose another min value.") + } + if (!missing(min)) { + if (any(x@ratings < min, na.rm = TRUE)) { # any rating value smaller than min? + stop( + "Some ratings are smaller than the min value you entered. ", + "The setting of the min value in the grid was not performed. ", + "Please check the ratings or choose another min value." + ) + } x@scale$min <- min } - if (!missing(max)){ - if (any(x@ratings > max, na.rm=TRUE)) # any rating value smaller than min? - stop("Some ratings are bigger than the max value you entered. ", - "The setting of the max value in the grid was not performed. ", - "Please check the ratings or choose another max value.") + if (!missing(max)) { + if (any(x@ratings > max, na.rm = TRUE)) { # any rating value smaller than min? + stop( + "Some ratings are bigger than the max value you entered. ", + "The setting of the max value in the grid was not performed. ", + "Please check the ratings or choose another max value." + ) + } x@scale$max <- max } - if (!missing(step)) + if (!missing(step)) { x@scale$step <- step + } x } # setScale(x, min=1, max=5, step=1) @@ -443,19 +479,21 @@ setScale <- function(x, min, max, step, ...){ # ... needes for makeRepgr #' #' @param x `repgrid` object. #' @param output Type of output object. 1= named vector, 2 = list. -#' @return Vector or list (depends on `output` containing +#' @return Vector or list (depends on `output` containing #' minimum and maximum scale value. #' @keywords internal #' @export -getScale <- function(x, output=1){ - if (!inherits(x, "repgrid")) # check if x is repgrid object +getScale <- function(x, output = 1) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object stop("Object x must be of class 'repgrid'") + } smin <- x@scale$min smax <- x@scale$max - if (output == 1) - res <- c(min=smin, max=smax) else - if (output == 2) - res <- list(min=smin, max=smax) + if (output == 1) { + res <- c(min = smin, max = smax) + } else if (output == 2) { + res <- list(min = smin, max = smax) + } res } @@ -474,21 +512,25 @@ getScale <- function(x, output=1){ #' @keywords internal #' @examples \dontrun{ #' -#' #### TODO #### +#' #### TODO #### #' } #' -setMeta <- function(x, type, id, name){ - if (!inherits(x, "repgrid")) # check if x is repgrid object +setMeta <- function(x, type, id, name) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object stop("Object x must be of class 'repgrid'") - if (!missing(type)) # rating, rank or implication + } + if (!missing(type)) { # rating, rank or implication x@meta$type <- type - if (!missing(name)) + } + if (!missing(name)) { x@meta$id <- id - if (!missing(name)) + } + if (!missing(name)) { x@meta$name <- name + } x } -#x <- setMeta(x, id=1, name="John Doe") +# x <- setMeta(x, id=1, name="John Doe") #' Get midpoint of the grid rating scale @@ -500,14 +542,14 @@ setMeta <- function(x, type, id, name){ #' @keywords internal #' @examples \dontrun{ #' -#' getScaleMidpoint(bell2010) -#' +#' getScaleMidpoint(bell2010) #' } #' -getScaleMidpoint <- function(x){ - if (!inherits(x, "repgrid")) # check if x is repgrid object +getScaleMidpoint <- function(x) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object stop("object x and y must be of class 'repgrid'") - (x@scale$max - x@scale$min)/2 + x@scale$min + } + (x@scale$max - x@scale$min) / 2 + x@scale$min } @@ -517,7 +559,7 @@ getScaleMidpoint <- function(x){ #' @return Midpoint of scale. #' #' @export -#' @examples +#' @examples #' midpoint(bell2010) #' midpoint <- getScaleMidpoint @@ -534,25 +576,28 @@ midpoint <- getScaleMidpoint #' @return `repgrid` object. #' @export #' @examples \dontrun{ -#' x <- randomGrid() -#' swapElements(x, 1, 3) # swap elements 1 and 3 -#' swapElements(x, 1:2, 3:4) # swap element 1 with 3 and 2 with 4 +#' x <- randomGrid() +#' swapElements(x, 1, 3) # swap elements 1 and 3 +#' swapElements(x, 1:2, 3:4) # swap element 1 with 3 and 2 with 4 #' } #' -swapElements <- function(x, pos1=1, pos2=1){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(any(c(pos1, pos2) < 0) | any(c(pos1, pos2)> length(x@elements))) - stop("pos1 and pos2 must be bigger than 1 and have number of elements as a maximum") - if(any(c(pos1, pos2) < 0) | any(c(pos1, pos2)> ncol(x@ratings))) - stop("pos1 and pos2 must be bigger than 1 and have number of elements as a maximum") - x@elements[c(pos1, pos2)] <- x@elements[c(pos2, pos1)] - x@ratings[,c(pos1, pos2),] <- x@ratings[,c(pos2, pos1),] - # x <- e.swopElementPosition(x, pos1=pos1, pos2=pos2) - # x <- r.swopRatingsColumns(x, pos1=pos1, pos2=pos2) - x +swapElements <- function(x, pos1 = 1, pos2 = 1) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (any(c(pos1, pos2) < 0) | any(c(pos1, pos2) > length(x@elements))) { + stop("pos1 and pos2 must be bigger than 1 and have number of elements as a maximum") + } + if (any(c(pos1, pos2) < 0) | any(c(pos1, pos2) > ncol(x@ratings))) { + stop("pos1 and pos2 must be bigger than 1 and have number of elements as a maximum") + } + x@elements[c(pos1, pos2)] <- x@elements[c(pos2, pos1)] + x@ratings[, c(pos1, pos2), ] <- x@ratings[, c(pos2, pos1), ] + # x <- e.swopElementPosition(x, pos1=pos1, pos2=pos2) + # x <- r.swopRatingsColumns(x, pos1=pos1, pos2=pos2) + x } -# @aliases swape +# @aliases swape # swape <- swapElements # alias # swopElements <- swapElements # swopE <- swapElements @@ -569,27 +614,29 @@ swapElements <- function(x, pos1=1, pos2=1){ #' @rdname swapConstructs #' @examples \dontrun{ #' -#' x <- randomGrid() -#' swapConstructs(x, 1, 3) # swap constructs 1 and 3 -#' swapConstructs(x, 1:2, 3:4) # swap construct 1 with 3 and 2 with 4 +#' x <- randomGrid() +#' swapConstructs(x, 1, 3) # swap constructs 1 and 3 +#' swapConstructs(x, 1:2, 3:4) # swap construct 1 with 3 and 2 with 4 #' } #' -swapConstructs <- function(x, pos1=1, pos2=1){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(any(c(pos1, pos2) < 0) | any(c(pos1, pos2)> nrow(x@ratings))) - stop("pos1 and pos2 must be bigger than 1 and have number of constructs as a maximum") - x@constructs[c(pos1, pos2)] <- x@constructs[c(pos2, pos1)] - x@ratings[c(pos1, pos2),,] <- x@ratings[c(pos2, pos1),,] +swapConstructs <- function(x, pos1 = 1, pos2 = 1) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (any(c(pos1, pos2) < 0) | any(c(pos1, pos2) > nrow(x@ratings))) { + stop("pos1 and pos2 must be bigger than 1 and have number of constructs as a maximum") + } + x@constructs[c(pos1, pos2)] <- x@constructs[c(pos2, pos1)] + x@ratings[c(pos1, pos2), , ] <- x@ratings[c(pos2, pos1), , ] # x <- c.swopConstructPosition(x, pos1=pos1, pos2=pos2) # x <- r.swopRatingsRows(x, pos1=pos1, pos2=pos2) - x + x } # @aliases swapc # swapc <- swapConstructs #alias # swopConstructs <- swapConstructs # swopC <- swapConstructs -#swopConstructs(rg, 1,2) +# swopConstructs(rg, 1,2) #' Reverse constructs / swaps construct poles @@ -602,65 +649,73 @@ swapConstructs <- function(x, pos1=1, pos2=1){ #' @param pos Row indexes of constructs to reverse.. #' @return A `repgrid` object with reversed constructs. #' @note Please note that the scale of the rating grid has to be set in order -#' to reverse constructs. If the scale is unknown no reversal occurs and an +#' to reverse constructs. If the scale is unknown no reversal occurs and an #' error is raised. #' @export #' @rdname reverse #' -#' @examples +#' @examples #' #' x <- boeker -#' -#' reverse(x) # reverse all constructs -#' reverse(x, 1) # reverse construct 1 -#' reverse(x, 1:2) # reverse constructs 1 and 2 -#' +#' +#' reverse(x) # reverse all constructs +#' reverse(x, 1) # reverse construct 1 +#' reverse(x, 1:2) # reverse constructs 1 and 2 +#' #' # swapPoles will become deprecated, use reverse instead -#' swapPoles(x, 1) # swap construct poles of construct +#' swapPoles(x, 1) # swap construct poles of construct #' -swapPoles <- function(x, pos) -{ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - if (missing(pos)) +swapPoles <- function(x, pos) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + if (missing(pos)) { pos <- seq_along(x@constructs) - if (any(pos <= 0 | pos > getNoOfConstructs(x))) - stop("pos must contains values greater than 0 and equal or less than number of constructs.") - if (identical(x@scale$min, NA) | identical(x@scale$min, NULL)) - stop("A min value for the scale has to be defined in order to swap poles.", - "To define the scale use setScale(). For more info type ?setScale to the console.") - if (identical(x@scale$max, NA) | identical(x@scale$max, NULL)) - stop("A min value for the scale has to be defined in order to swap poles.", - "To define the scale use setScale(). For more info type ?setScale to the console.") - - # swap names of poles - for (i in pos) { - tmp <- x@constructs[[i]]$leftpole - x@constructs[[i]]$leftpole <- x@constructs[[i]]$rightpole - x@constructs[[i]]$rightpole <- tmp - } + } + if (any(pos <= 0 | pos > getNoOfConstructs(x))) { + stop("pos must contains values greater than 0 and equal or less than number of constructs.") + } + if (identical(x@scale$min, NA) | identical(x@scale$min, NULL)) { + stop( + "A min value for the scale has to be defined in order to swap poles.", + "To define the scale use setScale(). For more info type ?setScale to the console." + ) + } + if (identical(x@scale$max, NA) | identical(x@scale$max, NULL)) { + stop( + "A min value for the scale has to be defined in order to swap poles.", + "To define the scale use setScale(). For more info type ?setScale to the console." + ) + } + + # swap names of poles + for (i in pos) { + tmp <- x@constructs[[i]]$leftpole + x@constructs[[i]]$leftpole <- x@constructs[[i]]$rightpole + x@constructs[[i]]$rightpole <- tmp + } # reverse ratings - nc <- ncol(x@ratings[pos, , , drop = FALSE]) - if (!nc == 0) { - x@ratings[pos, , ] <- x@scale$max - x@ratings[pos, , , drop = FALSE] + x@scale$min # TODO: maybe swapping not correct for layers 2 and 3??? - } - x + nc <- ncol(x@ratings[pos, , , drop = FALSE]) + if (!nc == 0) { + x@ratings[pos, , ] <- x@scale$max - x@ratings[pos, , , drop = FALSE] + x@scale$min # TODO: maybe swapping not correct for layers 2 and 3??? + } + x } #' @export #' @rdname reverse -reverse <- function(x, pos = 1L:nrow(x)) -{ +reverse <- function(x, pos = 1L:nrow(x)) { stop_if_not_is_repgrid(x) stop_if_scale_not_defined(x) nc <- nrow(x) - if (any(pos <= 0 | pos > nc)) + if (any(pos <= 0 | pos > nc)) { stop("all 'pos' must lie in the interval [1, ", nc, "]", call. = FALSE) - - # swap names of poles + } + + # swap names of poles lp <- leftpoles(x)[pos] - rp <- rightpoles(x)[pos] + rp <- rightpoles(x)[pos] leftpoles(x)[pos] <- rp rightpoles(x)[pos] <- lp @@ -676,7 +731,7 @@ reverse <- function(x, pos = 1L:nrow(x)) #' Move construct or element in grid to the left, right, up or down. #' #' @param x `repgrid` object. -#' @param pos Row (column) number of construct (element) to be moved +#' @param pos Row (column) number of construct (element) to be moved #' leftwards, rightwards, upwards or downwards. #' The default is `0`. For indexes outside the range of #' the grid no moving is done. @@ -684,21 +739,22 @@ reverse <- function(x, pos = 1L:nrow(x)) #' @export #' @aliases left right up down #' @examples \dontrun{ -#' x <- randomGrid() -#' left(x, 2) # 2nd element to the left -#' right(x, 1) # 1st element to the right -#' up(x, 2) # 2nd construct upwards -#' down(x, 1) # 1st construct downwards +#' x <- randomGrid() +#' left(x, 2) # 2nd element to the left +#' right(x, 1) # 1st element to the right +#' up(x, 2) # 2nd construct upwards +#' down(x, 1) # 1st construct downwards #' } #' @rdname move #' -left <- function(x, pos=0){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(!(pos<=1 | pos > getNoOfElements(x) | pos > ncol(x@ratings))){ # no moving if element is in first or last column - x <- swapElements(x, pos, pos-1) +left <- function(x, pos = 0) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") } - x + if (!(pos <= 1 | pos > getNoOfElements(x) | pos > ncol(x@ratings))) { # no moving if element is in first or last column + x <- swapElements(x, pos, pos - 1) + } + x } # @param x repgrid object @@ -712,15 +768,16 @@ left <- function(x, pos=0){ #' @export #' @rdname move #' -right <- function(x, pos=0){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(!(pos<0 | pos >= getNoOfElements(x) | pos >= ncol(x@ratings))){ # no moving if element is in first or last column - x <- swapElements(x, pos, pos+1) +right <- function(x, pos = 0) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (!(pos < 0 | pos >= getNoOfElements(x) | pos >= ncol(x@ratings))) { # no moving if element is in first or last column + x <- swapElements(x, pos, pos + 1) } # x <- e.moveElementRightwards(x, pos=pos) # x <- r.moveRatingsColumnRightwards(x, pos=pos) - x + x } @@ -733,15 +790,16 @@ right <- function(x, pos=0){ #' @export #' @rdname move #' -up <- function(x, pos=0){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - if (!(pos<=1 | pos > getNoOfConstructs(x) | pos > nrow(x@ratings))){ - x <- swapConstructs(x, pos, pos - 1) - } - # x <- c.moveConstructUpwards(x, pos=pos) +up <- function(x, pos = 0) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + if (!(pos <= 1 | pos > getNoOfConstructs(x) | pos > nrow(x@ratings))) { + x <- swapConstructs(x, pos, pos - 1) + } + # x <- c.moveConstructUpwards(x, pos=pos) # x <- r.moveRatingsRowUpwards(x, pos=pos) - x + x } # @param x repgrid object @@ -753,15 +811,16 @@ up <- function(x, pos=0){ #' @export #' @rdname move #' -down <- function(x, pos=0){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - if (!(pos < 1 | pos >= getNoOfConstructs(x) | pos >= nrow(x@ratings))){ - x <- swapConstructs(x, pos, pos + 1) - } +down <- function(x, pos = 0) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + if (!(pos < 1 | pos >= getNoOfConstructs(x) | pos >= nrow(x@ratings))) { + x <- swapConstructs(x, pos, pos + 1) + } # x <- c.moveConstructDownwards(x, pos=pos) # x <- r.moveRatingsRowDownwards(x, pos=pos) - x + x } @@ -769,7 +828,7 @@ down <- function(x, pos=0){ #' #' Shifts the whole grid vertically or horizontally so that the order remains #' the same but the prompted element or construct appears in first position. -#' +#' #' @param x `repgrid` object. #' @param c Index of construct to be shifted to first position. #' @param e Index of element to be shifted to first position. @@ -777,22 +836,26 @@ down <- function(x, pos=0){ #' @export #' @examples \dontrun{ #' -#' # shift element 13: 'Ideal self' to first position -#' shift(feixas2004, 13) +#' # shift element 13: 'Ideal self' to first position +#' shift(feixas2004, 13) #' -#' x <- randomGrid(5,10) -#' shift(x, 3, 5) +#' x <- randomGrid(5, 10) +#' shift(x, 3, 5) #' } #' -shift <- function(x, c=1, e=1){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - if (e < 1 | c < 1) - stop("Element or construct to be shifted to first position must have", - " a positive index") +shift <- function(x, c = 1, e = 1) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + if (e < 1 | c < 1) { + stop( + "Element or construct to be shifted to first position must have", + " a positive index" + ) + } ne <- length(x@elements) nc <- length(x@constructs) - x[ring(1:nc + c - 1, nc), ring(1:ne + e - 1, ne)] + x[ring(1:nc + c - 1, nc), ring(1:ne + e - 1, ne)] } @@ -805,27 +868,33 @@ shift <- function(x, c=1, e=1){ -r.setRatings <- function(x, scores=NA, rows=NA, cols=NA, layer=1, ...) -{ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(is.list(scores) & !is.data.frame(scores)) - stop("scores must not be a list.") - if(!(is.matrix(scores) | is.data.frame(scores) | is.vector(scores))) # check if scores is matrix, dataframe or vector - stop("scores must be matrix, dataframe or vector.") - if(is.data.frame(scores)) - scores <- as.matrix(scores) - if(is.na(rows[1]) & length(rows)==1) - rows <- 1:nrow(x@ratings) - if(is.na(cols[1]) & length(cols)==1) - cols <- 1:ncol(x@ratings) - if(max(rows) > nrow(x@ratings)) - stop("number of constructs does not exists.") - if(max(cols) > ncol(x@ratings)){ - stop("number of elements does not exists.") - } - x@ratings[rows, cols, layer] <- scores - x +r.setRatings <- function(x, scores = NA, rows = NA, cols = NA, layer = 1, ...) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (is.list(scores) & !is.data.frame(scores)) { + stop("scores must not be a list.") + } + if (!(is.matrix(scores) | is.data.frame(scores) | is.vector(scores))) { # check if scores is matrix, dataframe or vector + stop("scores must be matrix, dataframe or vector.") + } + if (is.data.frame(scores)) { + scores <- as.matrix(scores) + } + if (is.na(rows[1]) & length(rows) == 1) { + rows <- 1:nrow(x@ratings) + } + if (is.na(cols[1]) & length(cols) == 1) { + cols <- 1:ncol(x@ratings) + } + if (max(rows) > nrow(x@ratings)) { + stop("number of constructs does not exists.") + } + if (max(cols) > ncol(x@ratings)) { + stop("number of elements does not exists.") + } + x@ratings[rows, cols, layer] <- scores + x } rating <- r.setRatings @@ -843,13 +912,13 @@ rating <- r.setRatings #' @keywords internal #' @examples \dontrun{ #' -#' #### TODO #### +#' #### TODO #### #' } -clearRatings <- function(x, rows=NA, cols=NA, layer=1) { +clearRatings <- function(x, rows = NA, cols = NA, layer = 1) { x[rows, cols, layer] <- NA - x + x } -#clearRatings(x, 1, 1) +# clearRatings(x, 1, 1) #' Add an element to an existing grid. @@ -868,30 +937,33 @@ clearRatings <- function(x, rows=NA, cols=NA, layer=1) { #' @seealso [addConstruct()] #' @examples \dontrun{ #' -#' bell2010 -#' addElement(bell2010, "new element", c(1,2,5,4,3,6,5,2,7)) -#' +#' bell2010 +#' addElement(bell2010, "new element", c(1, 2, 5, 4, 3, 6, 5, 2, 7)) #' } #' -addElement <- function(x, name = NA, scores = NA, abbreviation = NA, status = NA, position = NA, side="pre") -{ - if (length(name) > 1 | length(abbreviation) > 1 | length(status) > 1) - stop("USERINFO: name, abbreviation and status must be of length one") - if (is.na(position)) - position <- ncol(x@ratings) + 1 - x <- e.addElements(x, name = name, abbreviation = abbreviation, - status = status, position = position, side = side) # basic element operation - x <- r.makeNewElementColumn(x, pos = position) # add column to ratings array - - # add scores/ratings - if (length(scores) != length(x@constructs) & - !is.na(scores[1]) & length(scores) != 1) { - warning("The number of ratings you entered do not match the number of constructs.") - scores <- scores[1:length(x@constructs)] # missing scores are filled up with NAs - } - if (length(x@constructs) > 0) - x <- rating(x, scores, cols = position) - return(x) +addElement <- function(x, name = NA, scores = NA, abbreviation = NA, status = NA, position = NA, side = "pre") { + if (length(name) > 1 | length(abbreviation) > 1 | length(status) > 1) { + stop("USERINFO: name, abbreviation and status must be of length one") + } + if (is.na(position)) { + position <- ncol(x@ratings) + 1 + } + x <- e.addElements(x, + name = name, abbreviation = abbreviation, + status = status, position = position, side = side + ) # basic element operation + x <- r.makeNewElementColumn(x, pos = position) # add column to ratings array + + # add scores/ratings + if (length(scores) != length(x@constructs) & + !is.na(scores[1]) & length(scores) != 1) { + warning("The number of ratings you entered do not match the number of constructs.") + scores <- scores[1:length(x@constructs)] # missing scores are filled up with NAs + } + if (length(x@constructs) > 0) { + x <- rating(x, scores, cols = position) + } + return(x) } # x <- makeEmptyRepgrid() # x <- addElement(x) @@ -916,31 +988,36 @@ addElement <- function(x, name = NA, scores = NA, abbreviation = NA, status = NA #' @examples #' addAvgElement(feixas2004, "others", i = 2:12) #' addAvgElement(feixas2004, "others", i = 2:12, digits = 0) # integers -#' +#' #' # exluding elements via negative indexes -#' addAvgElement(feixas2004, "others", i = c(-1,-13)) -#' -#' -addAvgElement <- function(x, name = "avg", i, digits = Inf) -{ - if (!is.repgrid(x)) +#' addAvgElement(feixas2004, "others", i = c(-1, -13)) +#' +addAvgElement <- function(x, name = "avg", i, digits = Inf) { + if (!is.repgrid(x)) { stop("'x' must be a repgrid object", call. = FALSE) - if (name %in% elements(x)) + } + if (name %in% elements(x)) { stop("element name '", name, "' already exists,", call. = FALSE) + } nc <- ncol(x) - if (!is.numeric(i) || !length(i) >= 1) + if (!is.numeric(i) || !length(i) >= 1) { stop("'i' must be a numeric vector with at least one entry", call. = FALSE) - if (!all(abs(i) >= 1) && all(abs(i) <= nc)) + } + if (!all(abs(i) >= 1) && all(abs(i) <= nc)) { stop("'i' must range between 1 and ", nc, call. = FALSE) - if (any(i < 0) && any(i > 0)) + } + if (any(i < 0) && any(i > 0)) { stop("It is not allowed to mix positive and negative indexes", call. = FALSE) - if (sum(duplicated(abs(i))) > 0) + } + if (sum(duplicated(abs(i))) > 0) { warning("duplicate indexes detected in 'i'", call. = FALSE) - + } + # convert negative indexes - if (all(i < 0)) + if (all(i < 0)) { i <- setdiff(1L:nc, abs(i)) - + } + R <- ratings(x) mean_ratings <- rowMeans(R[, i, drop = FALSE]) mean_ratings <- round(mean_ratings, digits = digits) @@ -969,29 +1046,31 @@ addAvgElement <- function(x, name = "avg", i, digits = Inf) #' #' @examples \dontrun{ #' -#' # show grid -#' bell2010 -#' addConstruct(bell2010, "left pole", "pole right", c(3,1,3,2,5,4,6,3,7,1)) -#' +#' # show grid +#' bell2010 +#' addConstruct(bell2010, "left pole", "pole right", c(3, 1, 3, 2, 5, 4, 6, 3, 7, 1)) #' } #' -addConstruct <- function(x, l.name = NA, r.name = NA, scores = NA, - l.preferred = NA, r.preferred = NA, - l.emerged = NA, r.emerged = NA, - position = NA, side = "pre"){ - if (is.na(position)) position <- length(x@constructs) + 1 - x <- c_addConstruct(x, l.name = l.name, l.preferred = l.preferred, l.emerged = l.emerged, - r.name = r.name, r.preferred = r.preferred, r.emerged = r.emerged, - position = position, side = side) - x <- r_makeNewConstructRow(x, pos = position) - # add scores/ratings - if (length(scores) != length(x@elements) & !is.na(scores[1]) & length(scores) != 1) { - warning("The number of ratings you entered do not match the number of elements.") - scores <- scores[1:length(x@elements)] # missing scores are filled up with NAs - } - if (length(x@elements) > 0) - x <- rating(x, scores, rows = position) - return(x) +addConstruct <- function(x, l.name = NA, r.name = NA, scores = NA, + l.preferred = NA, r.preferred = NA, + l.emerged = NA, r.emerged = NA, + position = NA, side = "pre") { + if (is.na(position)) position <- length(x@constructs) + 1 + x <- c_addConstruct(x, + l.name = l.name, l.preferred = l.preferred, l.emerged = l.emerged, + r.name = r.name, r.preferred = r.preferred, r.emerged = r.emerged, + position = position, side = side + ) + x <- r_makeNewConstructRow(x, pos = position) + # add scores/ratings + if (length(scores) != length(x@elements) & !is.na(scores[1]) & length(scores) != 1) { + warning("The number of ratings you entered do not match the number of elements.") + scores <- scores[1:length(x@elements)] # missing scores are filled up with NAs + } + if (length(x@elements) > 0) { + x <- rating(x, scores, rows = position) + } + return(x) } # x <- makeEmptyRepgrid() # x <- addConstruct(x) @@ -1006,31 +1085,34 @@ addConstruct <- function(x, l.name = NA, r.name = NA, scores = NA, #' Set the attributes of an element i.e. name, abbreviation, status etc. #' #' @param x `repgrid` object. -#' @param pos Column number of element in the grid whose attributes +#' @param pos Column number of element in the grid whose attributes #' are changed. #' @param name New element name (optional). #' @param abb Abbreviation of element name (optional). #' @param status Status of element (e.g. ideal etc.) (optional). #' @return `repgrid` object #' -#' @note Currently the main purpose is to change element names. +#' @note Currently the main purpose is to change element names. #' Future implementations will allow to set further attributes. #' @export #' @seealso [setConstructAttr()] #' @examples \dontrun{ -#' -#' x <- setElementAttr(boeker, 1, "new name") # change name of first element -#' x +#' +#' x <- setElementAttr(boeker, 1, "new name") # change name of first element +#' x #' } #' -setElementAttr <- function(x, pos, name, abb, status){ +setElementAttr <- function(x, pos, name, abb, status) { e <- x@elements[[pos]] - if (! missing(name)) + if (!missing(name)) { e$name <- name - if (! missing(abb)) - e$abbreviation <- abb - if (! missing(status)) - e$status <- status + } + if (!missing(abb)) { + e$abbreviation <- abb + } + if (!missing(status)) { + e$status <- status + } x@elements[pos] <- list(e) x } @@ -1038,7 +1120,7 @@ setElementAttr <- function(x, pos, name, abb, status){ # setElementAttr(x, 1, "test") # new name # setElementAttr(x, 1, abb="test") # new abbreviation # setElementAttr(x, 1, status="ideal") # new status -# setElementAttr(x, 1, "new name", +# setElementAttr(x, 1, "new name", # "new abbreviation", "new status") # all new @@ -1052,7 +1134,7 @@ setElementAttr <- function(x, pos, name, abb, status){ #' @param r.name Name of the right pole (string) (optional). #' @param l.preferred Logical. Is the left one the preferred pole? (optional). #' @param r.preferred Logical. Is the right one the preferred pole? (optional). -#' @param l.emerged Logical. Is the left one the emergent pole? (optional). +#' @param l.emerged Logical. Is the left one the emergent pole? (optional). #' @param r.emerged Logical. Is the right one the emergent pole? (optional). #' @return `repgrid` object #' @@ -1060,26 +1142,34 @@ setElementAttr <- function(x, pos, name, abb, status){ #' @seealso [setElementAttr()] #' @examples \dontrun{ #' -#' x <- setConstructAttr(bell2010, 1, -#' "new left pole", "new right pole") -#' x +#' x <- setConstructAttr( +#' bell2010, 1, +#' "new left pole", "new right pole" +#' ) +#' x #' } #' -setConstructAttr <- function(x, pos, l.name, r.name, l.preferred, r.preferred, - l.emerged, r.emerged){ - con <- x@constructs[[1]] - if (! missing(l.name)) +setConstructAttr <- function(x, pos, l.name, r.name, l.preferred, r.preferred, + l.emerged, r.emerged) { + con <- x@constructs[[1]] + if (!missing(l.name)) { con$leftpole$name <- l.name - if (! missing(l.preferred)) + } + if (!missing(l.preferred)) { con$leftpole$preffered <- l.preferred - if (! missing(l.emerged)) + } + if (!missing(l.emerged)) { con$leftpole$emerged <- l.emerged - if (! missing(r.name)) + } + if (!missing(r.name)) { con$rightpole$name <- r.name - if (! missing(r.preferred)) + } + if (!missing(r.preferred)) { con$rightpole$preffered <- r.preferred - if (! missing(r.emerged)) - con$rightpole$emerged <- r.emerged + } + if (!missing(r.emerged)) { + con$rightpole$emerged <- r.emerged + } x@constructs[pos] <- list(con) x } @@ -1088,11 +1178,11 @@ setConstructAttr <- function(x, pos, l.name, r.name, l.preferred, r.preferred, -# MAYBE OBSOLETE as setConstructAttr does the same. -# modifyConstructs() allows to change the properties of a construct (left and -# right pole as well as preferred and emergent property). By default the new -# values get added to the old ones, i.e. specifying l.name only overwrites -# l.name. If you want to reset all properties use replace=TRUE. Default +# MAYBE OBSOLETE as setConstructAttr does the same. +# modifyConstructs() allows to change the properties of a construct (left and +# right pole as well as preferred and emergent property). By default the new +# values get added to the old ones, i.e. specifying l.name only overwrites +# l.name. If you want to reset all properties use replace=TRUE. Default # is NA for all properties. #' modify a construct @@ -1113,25 +1203,30 @@ setConstructAttr <- function(x, pos, l.name, r.name, l.preferred, r.preferred, #' @keywords internal #' @examples \dontrun{ #' -#' #### TODO #### +#' #### TODO #### #' } #' -modifyConstruct <- function(x, pos, l.name=NA, l.preferred=NA, l.emerged=NA, - r.name=NA, r.preferred=NA, r.emerged=NA, - replace=FALSE){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - cs <- c_makeNewConstruct(x=NULL , - l.name=l.name, - l.preferred=l.preferred, - l.emerged=l.emerged, - r.name=r.name, - r.preferred=r.preferred, - r.emerged=r.emerged) - if(replace){ - x@constructs[pos] <- list(modifyList(x@constructs[[pos]], cs)) - } else x@constructs[pos] <- list(modifyListNA(x@constructs[[pos]], cs)) - x +modifyConstruct <- function(x, pos, l.name = NA, l.preferred = NA, l.emerged = NA, + r.name = NA, r.preferred = NA, r.emerged = NA, + replace = FALSE) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + cs <- c_makeNewConstruct( + x = NULL, + l.name = l.name, + l.preferred = l.preferred, + l.emerged = l.emerged, + r.name = r.name, + r.preferred = r.preferred, + r.emerged = r.emerged + ) + if (replace) { + x@constructs[pos] <- list(modifyList(x@constructs[[pos]], cs)) + } else { + x@constructs[pos] <- list(modifyListNA(x@constructs[[pos]], cs)) + } + x } @@ -1150,27 +1245,32 @@ modifyConstruct <- function(x, pos, l.name=NA, l.preferred=NA, l.emerged=NA, #' @keywords internal #' @examples \dontrun{ #' -#' #### TODO #### +#' #### TODO #### #' } -modifyElement <- function(x, pos, name=NA, abbreviation=NA, status=NA, - replace=FALSE){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - e <- e.makeNewElement(x=NULL , name=name, - abbreviation=abbreviation, status=status) - if(replace){ - x@elements[pos] <- list(modifyList(x@elements[[pos]], e)) - } else x@elements[pos] <- list(modifyListNA(x@elements[[pos]], e)) - x +modifyElement <- function(x, pos, name = NA, abbreviation = NA, status = NA, + replace = FALSE) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + e <- e.makeNewElement( + x = NULL, name = name, + abbreviation = abbreviation, status = status + ) + if (replace) { + x@elements[pos] <- list(modifyList(x@elements[[pos]], e)) + } else { + x@elements[pos] <- list(modifyListNA(x@elements[[pos]], e)) + } + x } -#x <- makeEmptyRepgrid() -#x <- addElements(x, c("Element 1", "Element 2")) -#x <- modifyElement(x, pos=2, name="test") +# x <- makeEmptyRepgrid() +# x <- addElements(x, c("Element 1", "Element 2")) +# x <- modifyElement(x, pos=2, name="test") + - #' Print scale range information to the console. #' #' @param x `repgrid` object. @@ -1179,37 +1279,42 @@ modifyElement <- function(x, pos, name=NA, abbreviation=NA, status=NA, #' @keywords internal #' @examples \dontrun{ #' -#' showScale(raeithel) -#' showScale(bell2010) +#' showScale(raeithel) +#' showScale(bell2010) #' } #' -showScale <- function(x){ +showScale <- function(x) { cat("\nSCALE INFO:\n") - if(!is.null(x@scale$min) & !is.null(x@scale$max)) { - cat("The grid is rated on a scale from", x@scale$min, - "(left pole) to", x@scale$max, "(right pole)\n")#, - # "using steps of", x@scale$step, "\n") + if (!is.null(x@scale$min) & !is.null(x@scale$max)) { + cat( + "The grid is rated on a scale from", x@scale$min, + "(left pole) to", x@scale$max, "(right pole)\n" + ) # , + # "using steps of", x@scale$step, "\n") } else { - cat("warning: the scale for this grid is not defined.", - "Certain functions rely on the scale definition.", - "To define the scale use setScale().", - "For more info type ?setScale to the console.\n") + cat( + "warning: the scale for this grid is not defined.", + "Certain functions rely on the scale definition.", + "To define the scale use setScale().", + "For more info type ?setScale to the console.\n" + ) } invisible(NULL) } -#showScale(x) +# showScale(x) # the slot coupled can be influenced -# If a grid is changed from couled to uncoupled, the data is double but +# If a grid is changed from couled to uncoupled, the data is double but # with reflected scales. A scale range has to be defined for that operations -setCoupled <- function(x, coupled=TRUE){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - if (isTRUE(x@coupled) & !coupled) { - x <- doubleEntry(x) - } - x +setCoupled <- function(x, coupled = TRUE) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + if (isTRUE(x@coupled) & !coupled) { + x <- doubleEntry(x) + } + x } # x <- bell2010 @@ -1223,73 +1328,79 @@ setCoupled <- function(x, coupled=TRUE){ #' prints meta information about the grid to the console (id, name of interviewee etc.) #' #' @param x repgrid object -#' @return `NULL` +#' @return `NULL` #' @export #' @keywords internal #' @examples \dontrun{ #' -#' #### TODO #### +#' #### TODO #### #' } #' -showMeta <- function(x){ +showMeta <- function(x) { cat("\nMETA DATA:\n") - if(!is.null(x@meta$type)) - cat("Grid type: ", x@meta$type, "\n") # print Meta data - if(!is.null(x@meta$id)) - cat("Interview id: ", x@meta$id, "\n") # print Meta data - if(!is.null(x@meta$name)) + if (!is.null(x@meta$type)) { + cat("Grid type: ", x@meta$type, "\n") + } # print Meta data + if (!is.null(x@meta$id)) { + cat("Interview id: ", x@meta$id, "\n") + } # print Meta data + if (!is.null(x@meta$name)) { cat("Name of interview partner: ", x@meta$name, "\n") + } cat("Number of constructs: ", length(x@constructs), "\n") cat("Number of elements: ", length(x@elements), "\n") } -#showMeta(x) +# showMeta(x) -#' Make a new repgrid object. +#' Make a new repgrid object. #' #' The function creates a `repgrid` #' object from scratch. A number of parameters have to be defined in order to #' make a new grid (see parameters). #' #' @param args Arguments needed for the construction of the grid (list). -#' These include `name` followed by a vector containing -#' the element names. `l.name` followed by a vector with -#' the left construct poles. `r.name` followed by a +#' These include `name` followed by a vector containing +#' the element names. `l.name` followed by a vector with +#' the left construct poles. `r.name` followed by a #' vector with the right construct poles. `scores` followed #' by a vector containing the rating scores row wise. -#' @return `NULL` +#' @return `NULL` #' @export #' @examples \dontrun{ #' -#' # make list object containing the arguments -#' args <- list( name=c("element_1", "element_2", "element_3", "element_4"), -#' l.name=c("left_1", "left_2", "left_3"), -#' r.name=c("right_1", "right_2", "right_3"), -#' scores=c( 1,0,1,0, -#' 1,1,1,0, -#' 1,0,1,0 ) ) -#' # make grid object -#' x <- makeRepgrid(args) -#' x +#' # make list object containing the arguments +#' args <- list( +#' name = c("element_1", "element_2", "element_3", "element_4"), +#' l.name = c("left_1", "left_2", "left_3"), +#' r.name = c("right_1", "right_2", "right_3"), +#' scores = c( +#' 1, 0, 1, 0, +#' 1, 1, 1, 0, +#' 1, 0, 1, 0 +#' ) +#' ) +#' # make grid object +#' x <- makeRepgrid(args) +#' x #' } #' -makeRepgrid <- function(args) -{ - x <- makeEmptyRepgrid() - l <- c(list(x=x), args) # make a new repgrid object +makeRepgrid <- function(args) { + x <- makeEmptyRepgrid() + l <- c(list(x = x), args) # make a new repgrid object x <- do.call(e.setElements, l) - l <- c(list(x=x), args) # make a new repgrid object + l <- c(list(x = x), args) # make a new repgrid object x <- do.call(c.setConstructs, l) - x <- initRatingArray(x) # initialize rating array - l <- c(list(x=x), args) # make a new repgrid object - x[ , ] <- matrix(args$scores, ncol=getNoOfElements(x), byrow=T) # to fill matrix rowwise - #x <- do.call(r.setRatings, l) # old version - l <- c(list(x=x), args) # make a new repgrid object - x <- do.call(rg.setCoupled, l) # if no coupled argument then coupled=TRUE - l <- c(list(x=x), args) # make a new repgrid object - x <- do.call(setScale, l) # set scale if min and max arg is provided + x <- initRatingArray(x) # initialize rating array + l <- c(list(x = x), args) # make a new repgrid object + x[, ] <- matrix(args$scores, ncol = getNoOfElements(x), byrow = T) # to fill matrix rowwise + # x <- do.call(r.setRatings, l) # old version + l <- c(list(x = x), args) # make a new repgrid object + x <- do.call(rg.setCoupled, l) # if no coupled argument then coupled=TRUE + l <- c(list(x = x), args) # make a new repgrid object + x <- do.call(setScale, l) # set scale if min and max arg is provided x } # args <- list( name=c("element_1", "element_2", "element_3", "element_4"), @@ -1304,8 +1415,8 @@ makeRepgrid <- function(args) -#' Concatenate the constructs of two grids. -#' +#' Concatenate the constructs of two grids. +#' #' I.e. the constructs are combined to form one long grid. #' This function can be used in order to analyze multiple grids #' as one 'big grid' (eg. Slater, 1977, chap. 11). @@ -1317,92 +1428,98 @@ makeRepgrid <- function(args) #' (if `test=TRUE`, default). If set to FALSE an error occurs #' if the element order is not identical in both grids. #' @param index TODO. Logical (default `TRUE`). Whether to add an index at the end -#' of each construct name so it remains clear from which grid each -#' construct came. +#' of each construct name so it remains clear from which grid each +#' construct came. #' #' @return `repgrid` object #' -#' @references Slater, P. (1977). *The measurement of intrapersonal space +#' @references Slater, P. (1977). *The measurement of intrapersonal space #' by grid technique*. London: Wiley. #' #' @export #' @keywords internal #' @examples \dontrun{ #' -#' a <- randomGrid() -#' b <- randomGrid() -#' b@@elements <- rev(a@@elements) # reverse elements -#' bindConstructs(a, b) -#' -#' bindConstructs(a, b, m=F) # no binding +#' a <- randomGrid() +#' b <- randomGrid() +#' elements(b) <- rev(elements(a)) # reverse elements +#' bindConstructs(a, b) +#' +#' bindConstructs(a, b, m = F) # no binding #' } #' -bind <- function(x, y, match=TRUE, index=TRUE) -{ - if (!inherits(x, "repgrid") | !inherits(y, "repgrid")) # check if x is repgrid object - stop("object x and y must be of class 'repgrid'", call. = FALSE) - if (getNoOfElements(x) != getNoOfElements(y)) # check if grid has same number of columns - stop("grids must have the same number of elements", call. = FALSE) - if (any(getScale(x) != getScale(y))) +bind <- function(x, y, match = TRUE, index = TRUE) { + if (!inherits(x, "repgrid") | !inherits(y, "repgrid")) { # check if x is repgrid object + stop("object x and y must be of class 'repgrid'", call. = FALSE) + } + if (getNoOfElements(x) != getNoOfElements(y)) { # check if grid has same number of columns + stop("grids must have the same number of elements", call. = FALSE) + } + if (any(getScale(x) != getScale(y))) { stop("concatenated grids must have identical scale ranges", call. = FALSE) + } names.x <- elements(x) names.y <- elements(y) - if (!all(names.x %in% names.y)) + if (!all(names.x %in% names.y)) { stop("grids must have the same set of elements", call. = FALSE) - - if (match & !identical(names.x, names.y)){ - #y <- y[ ,orderByString(names.x, names.y)] - reorder.index.y <- match(names.x, names.y) # reorder elements of y by elements of x - y <- y[ , reorder.index.y] - } else if (!match & !identical(names.x, names.y)){ - stop("elements are the same but dop not have the same order.", - "choose reorder=TRUE if you want to allow matching of element positions") - } - x <- x[ , ] # to counteract that decoupled arrays are dropped when using [, ] - y <- y[ , ] + } + + if (match & !identical(names.x, names.y)) { + # y <- y[ ,orderByString(names.x, names.y)] + reorder.index.y <- match(names.x, names.y) # reorder elements of y by elements of x + y <- y[, reorder.index.y] + } else if (!match & !identical(names.x, names.y)) { + stop( + "elements are the same but dop not have the same order.", + "choose reorder=TRUE if you want to allow matching of element positions" + ) + } + x <- x[, ] # to counteract that decoupled arrays are dropped when using [, ] + y <- y[, ] res <- x - res@ratings <- abind(x@ratings[ , , , drop=FALSE], - y@ratings[ , , , drop=FALSE], along=1) + res@ratings <- abind(x@ratings[, , , drop = FALSE], + y@ratings[, , , drop = FALSE], + along = 1 + ) res@constructs <- c(x@constructs, y@constructs) res } -#' Concatenate the constructs of two or more grids. -#' +#' Concatenate the constructs of two or more grids. +#' #' I.e. the constructs are combined to form one long grid. -#' The girds must have the same set of elements and an identical +#' The girds must have the same set of elements and an identical #' scale range. The order of the elements may differ. -#' +#' #' This function can be used in order to analyze multiple grids #' as one 'big grid' (eg. Slater, 1977, chap. 11). #' #' @param ... One or more repgrid objects or a list containing #' `repgrid` object. #' @param index TODO. Logical (default `TRUE`). Whether to add an index at the end -#' of each construct name so it remains clear from which grid each -#' construct came. +#' of each construct name so it remains clear from which grid each +#' construct came. #' #' @return `repgrid` object with concatenated constructs. #' -#' @references Slater, P. (1977). *The measurement of intrapersonal space +#' @references Slater, P. (1977). *The measurement of intrapersonal space #' by grid technique*. London: Wiley. #' @export -#' @examples -#' -#' a <- randomGrid() -#' b <- randomGrid() -#' b@@elements <- rev(a@@elements) # reverse elements -#' bindConstructs(a, b) -#' bindConstructs(a, b, a) -#' -#' # using lists of repgrid objects -#' bindConstructs(a, list(a, b)) -#' -bindConstructs <- function(..., index=FALSE) -{ - dots <- list(...) - dots <- unlist(dots) # in case list of repgrid objects are supplied +#' @examples +#' +#' a <- randomGrid() +#' b <- randomGrid() +#' elements(b) <- rev(elements(a)) # reverse elements +#' bindConstructs(a, b) +#' bindConstructs(a, b, a) +#' +#' # using lists of repgrid objects +#' bindConstructs(a, list(a, b)) +#' +bindConstructs <- function(..., index = FALSE) { + dots <- list(...) + dots <- unlist(dots) # in case list of repgrid objects are supplied is.grid <- sapply(dots, function(x) inherits(x, "repgrid")) Reduce("bind", dots[is.grid]) } @@ -1412,44 +1529,50 @@ bindConstructs <- function(..., index=FALSE) # @docType methods #' Concatenate repgrid objects. -#' +#' #' Simple concatenation of repgrid objects or list containing #' repgrid objects using the '+' operator. #' -#' Methods for `"+"` function. +#' Methods for `"+"` function. #' @param e1,e2 A `repgrid` object. #' @rdname ops-methods #' @include repgrid.r #' @export -#' @examples -#' +#' @examples +#' #' x <- bell2010 #' x + x -#' x + list(x,x) -#' list(x,x) + x +#' x + list(x, x) +#' list(x, x) + x #' -setMethod("+", signature(e1="repgrid", e2="repgrid"), - function(e1, e2) bindConstructs(e1, e2)) +setMethod( + "+", signature(e1 = "repgrid", e2 = "repgrid"), + function(e1, e2) bindConstructs(e1, e2) +) #' @docType methods #' @aliases +,list,repgrid-method #' @rdname ops-methods -#' -setMethod("+", signature(e1="list", e2="repgrid"), - function(e1, e2) { - bindConstructs(e1, e2) - }) +#' +setMethod( + "+", signature(e1 = "list", e2 = "repgrid"), + function(e1, e2) { + bindConstructs(e1, e2) + } +) #' @docType methods #' @aliases +,repgrid,list-method #' @rdname ops-methods #' -setMethod("+", signature(e1="repgrid", e2="list"), - function(e1, e2) { - bindConstructs(e1, e2) - }) +setMethod( + "+", signature(e1 = "repgrid", e2 = "list"), + function(e1, e2) { + bindConstructs(e1, e2) + } +) #' Join the constructs of a grid with the same reversed constructs. @@ -1462,22 +1585,22 @@ setMethod("+", signature(e1="repgrid", e2="list"), #' @keywords internal #' @examples \dontrun{ #' -#' data(bell2010) -#' doubleEntry(bell2010) +#' data(bell2010) +#' doubleEntry(bell2010) #' } #' -doubleEntry <- function(x){ +doubleEntry <- function(x) { bindConstructs(x, swapPoles(x)) } -#' Return size of a grid. +#' Return size of a grid. #' #' `dim` returns a numeric vector of length #' two containing the number of constructs and elements. #' #' @param x `repgrid` object. -#' @return Numeric vector of length two with the number of +#' @return Numeric vector of length two with the number of #' constructs and elements. #' @export #' @keywords internal @@ -1485,23 +1608,24 @@ doubleEntry <- function(x){ #' @seealso [getNoOfConstructs()]; [getNoOfElements()] #' @examples \dontrun{ #' -#' dim(bell2010) -#' +#' dim(bell2010) #' } #' -dim.repgrid <- function(x){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("object x and y must be of class 'repgrid'") - c(constructs=getNoOfConstructs(x), elements=getNoOfElements(x)) +dim.repgrid <- function(x) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("object x and y must be of class 'repgrid'") + } + c(constructs = getNoOfConstructs(x), elements = getNoOfElements(x)) } # set status coupled equals TRIE or FALSE. Depending on the setting, # certain functions will work differently # -rg.setCoupled <- function(x, coupled=TRUE, ...){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") +rg.setCoupled <- function(x, coupled = TRUE, ...) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } x@coupled <- coupled x } @@ -1513,17 +1637,17 @@ rg.setCoupled <- function(x, coupled=TRUE, ...){ #' @export #' @keywords internal #' -decouple <- function(x){ +decouple <- function(x) { if (x@coupled) { - x <- doubleEntry(x) - x@coupled <- FALSE + x <- doubleEntry(x) + x@coupled <- FALSE } x } #' Invert construct and element order -#' +#' #' @param x A `repgrid` object. #' @param what A string or numeric to indicate if constructs (`"C"`, `1`) or #' elements (`"C"`, `1`), or both (`"CE"`, `12`) should be reversed. @@ -1531,40 +1655,37 @@ decouple <- function(x){ #' @export #' @rdname reorder #' -#' @examples -#' +#' @examples +#' #' # invert order of constructs #' reorder(boeker, "C") #' reorder(boeker, 1) -#' +#' #' # invert order of elements #' reorder(boeker, "E") #' reorder(boeker, 2) -#' +#' #' # invert both (default) #' reorder(boeker) #' reorder(boeker, "CE") #' reorder(boeker, 12) -#' +#' #' # not reordering #' reorder(boeker, NA) -#' -reorder.repgrid <- function(x, what = "CE", ...) -{ - if (!is.repgrid(x)) +#' +reorder.repgrid <- function(x, what = "CE", ...) { + if (!is.repgrid(x)) { stop("Object 'x' must be of class 'repgrid'", call. = FALSE) - if (is.null(what) || is.na(what)) + } + if (is.null(what) || is.na(what)) { return(x) + } what <- toupper(as.character(what)) - if (str_detect(what, "C|1")) + if (str_detect(what, "C|1")) { x <- x[rev(seq_len(nrow(x))), ] - if (str_detect(what, "E|2")) + } + if (str_detect(what, "E|2")) { x <- x[, rev(seq_len(ncol(x)))] + } x } - - - - - - diff --git a/R/repgrid-constructs.r b/R/repgrid-constructs.r index 84faac41..cdaf76e4 100644 --- a/R/repgrid-constructs.r +++ b/R/repgrid-constructs.r @@ -1,420 +1,452 @@ -#----------------------------------------------# -### basic construct operations ### -#----------------------------------------------# - -# Function that start with c. operate on the constructs only. -# These functions serve for basic operations on constructs. -# In case a function needs to operate on constructs and other -# slots (e.g. elements, ratings) higher-level functions -# that perform joints operations are used. The base operations -# are not needed when using openrepgrid by the user. - -## constructs -# add constructs -# delete constructs -# rename pole(s) -# change construct order -# set pole status (emerged, preferred etc.) -# reverse poles - -# pole--+ -# +--name -# +--preferred -# +--emerged - - - -############## FUNCTIONS TO RETRIEVE INFORMATION FROM REPGRID OBJECTS ################## - -#' Get construct names -#' -#' @param x `repgrid` object. -#' @section Deprecated functions: `getConstructNames()`, -#' and `cNames()` have been deprecated. -#' Instead use `constructs()`. -#' @export -#' @keywords internal -#' -getConstructNames <- function(x){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - - l <- lapply(x@constructs, function(x) - data.frame(leftpole=x$leftpole$name, - rightpole=x$rightpole$name, stringsAsFactors=FALSE)) - list_to_dataframe(l) -} -cNames <- getConstructNames - - -#' Retrieves the construct names from a `repgrid`. -#' -#' Different features like trimming, indexing and choices of separators -#' allow to return the kind of format that is needed. -#' -#' @title Retrieve construct names in needed format. -#' -#' @param x `repgrid` object. -#' @param mode Type of output. 1= left and right pole -#' separated by `sep`), 2= only left pole, -#' 3 = only right pole. -#' @param trim Number of characters to trim the construct names to -#' (default `NA`). `NA` will suppress trimming. -#' The length of `index` is not included in the -#' trimming. -#' @param index Logical. Whether to add a index number before the construct -#' names (default `TRUE`). -#' @param sep Separator string between poles. -#' @param pre String before index number (default `(`). -#' @param post String after index number (default `) `). -#' @return Vector with construct names. -#' @export -#' @keywords internal -#' @examples \dontrun{ -#' -#' getConstructNames2(bell2010) -#' getConstructNames2(bell2010, mode=2) -#' getConstructNames2(bell2010, index=T) -#' getConstructNames2(bell2010, index=T, mode=3) -#' -#' } -#' -getConstructNames2 <- function(x, mode=1, trim=20, index=F, - sep = " - ", pre="(", post=") " ){ - if (!inherits(x, "repgrid")) - stop("Object x must be of class 'repgrid'") - - cnames <- constructs(x) - cnames.l <- cnames[ ,1] - cnames.r <- cnames[ ,2] - - # add numeric index in front of constructs - if (index) - ind <- paste(pre, seq_along(cnames.l), post, sep="") else - ind <- "" - - # trim names if prompted - if (!is.na(trim)){ - if( mode == 1 ) # adjust trimming length if both sides are included - trim <- ceiling(trim / 2) - cnames.l <- substr(cnames.l, 1, trim) - cnames.r <- substr(cnames.r, 1, trim) - } - - if (mode == 1) # left and right poles - cnames.new <- paste(ind, cnames.l, sep, cnames.r, sep="") - if (mode == 2) # left pole only - cnames.new <- paste(ind, cnames.l, sep="") - if (mode == 3) # right pole only - cnames.new <- paste(ind, cnames.r, sep="") - cnames.new -} - - -#' Get or replace construct poles -#' -#' Allows to get and set construct poles. -#' Replaces the older functions `getConstructNames`, `getConstructNames2`, -#' and `eNames` which are deprecated. -#' -#' @param x A repgrid object. -#' @param i,j Row and column Index of repgrid matrix. -#' @param value Character vector of poles. -#' @param collapse Return vector with both poles instead. -#' @param sep Separator if `collapse = TRUE`, default is `" - "`. -#' @rdname constructs -#' @export -#' -#' @examples -#' -#' # shorten object name -#' x <- boeker -#' -#' ## get construct poles -#' constructs(x) # both left and right poles -#' leftpoles(x) # left poles only -#' rightpoles(x) -#' constructs(x, collapse = TRUE) -#' -#' ## replace construct poles -#' constructs(x)[1,1] <- "left pole 1" -#' constructs(x)[1,"leftpole"] <- "left pole 1" # alternative -#' constructs(x)[1:3,2] <- paste("right pole", 1:3) -#' constructs(x)[1:3,"rightpole"] <- paste("right pole", 1:3) # alternative -#' constructs(x)[4,1:2] <- c("left pole 4", "right pole 4") -#' -#' l <- leftpoles(x) -#' leftpoles(x) <- sample(l) # brind poles into random order -#' leftpoles(x)[1] <- "new left pole 1" # replace name of first left pole -#' -#' # replace left poles of constructs 1 and 3 -#' leftpoles(x)[c(1,3)] <- c("new left pole 1", "new left pole 3") -#' -constructs <- function(x, collapse = FALSE, sep = " - ") -{ - # check if x is a repgrid object - if (!inherits(x, "repgrid")) - stop("Object x must be of class 'repgrid'.") - - # get left and right pole name properties from each construct - df <- data.frame( - leftpole = leftpoles(x), - rightpole = rightpoles(x), - stringsAsFactors = FALSE - ) - if (collapse) { - res <- paste0(df$leftpole, sep, df$rightpole) - return(res) - } - df -} - - -#' @rdname constructs -#' @export -`constructs<-` <- function(x, i, j, value) -{ - # check if x is a repgrid object - if (!inherits(x, "repgrid")) - stop("Object x must be of class 'repgrid'.") - - # get dataframe and replace using bracket operator - # this replacement type function somehow works. - # Other attempts falied. - d <- constructs(x) - d[i, j] <- value - - # replace left and right poles - leftpoles(x) <- d$leftpole - rightpoles(x) <- d$rightpole - - x -} - - -#' @rdname constructs -#' @export -leftpoles <- function(x) -{ - # check if x is a repgrid object - if (!inherits(x, "repgrid")) - stop("Object x must be of class 'repgrid'.") - - # get left pole name property from each construct - sapply(x@constructs, function(x) x$leftpole$name) -} - - -#' @param position Index where to insert construct -#' @param value Character vector of construct poles names. -#' @rdname constructs -#' @export -`leftpoles<-` <- function(x, position, value) -{ - # check if x is a repgrid object - if (!inherits(x, "repgrid")) - stop("Object x must be of class 'repgrid'.") - - # get element names and replace one or more - p <- leftpoles(x) - p[position] <- value - - # replace leftpole name property of each construct - for (i in seq_along(p)) - x@constructs[[i]]$leftpole$name <- p[i] - - x -} - -#' @rdname constructs -#' @export -rightpoles <- function(x) -{ - # check if x is a repgrid object - if (!inherits(x, "repgrid")) - stop("Object x must be of class 'repgrid'.") - - # get left pole name property from each construct - sapply(x@constructs, function(x) x$rightpole$name) -} - -#' @rdname constructs -#' @export -`rightpoles<-` <- function(x, position, value) -{ - # check if x is a repgrid object - if (!inherits(x, "repgrid")) - stop("Object x must be of class 'repgrid'.") - - # get element names and replace one or more - p <- rightpoles(x) - p[position] <- value - - # replace leftpole name property of each construct - for (i in seq_along(p)) - x@constructs[[i]]$rightpole$name <- p[i] - - x -} - - - -constructInfo <- function(x, all=TRUE){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - l <- lapply(x@constructs, function(x) data.frame( - leftpole=x$leftpole$name, - l.preffered=x$leftpole$preferred, - l.emerged=x$leftpole$emerged, - rightpole=x$rightpole$name, - r.preffered=x$rightpole$preferred, - r.emerged=x$rightpole$emerged, - stringsAsFactors=FALSE)) - info <- list_to_dataframe(l) #old version using lapply above - if (all) - info else - info[c("leftpole", "rightpole")] -} -cInfo <- constructInfo -#constructInfo(x) - - -getNoOfConstructs <- function(x){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - length(x@constructs) -} -nc <- getNoOfConstructs - - - - -# internal. c_makeNewConstruct is the constructor for construct object (simple list) -c_makeNewConstruct <- function(x=NULL, l.name=NA, l.preferred=NA, l.emerged=NA, - r.name=NA, r.preferred=NA, r.emerged=NA, ...){ - list(leftpole=list(name=l.name, - preferred=l.preferred, - emerged=l.emerged), - rightpole=list(name=r.name, - preferred=r.preferred, - emerged=r.emerged)) -} -#str(c_makeNewConstruct()) - - - -# internal: c.setConstructs sets constructs by index -c.setConstructs <- function(x, l.name=NA, l.preferred=NA, l.emerged=NA, - r.name=NA, r.preferred=NA, r.emerged=NA, - index=NULL, ...){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(!is.atomic(l.name) | !is.atomic(l.name)) - stop("arguments l.name and r.name must be a vector") - if(!is.logical(c(l.preferred, l.emerged, r.preferred, r.emerged))) - stop("arguments l.preferred, r.preferred, l.emerged and r.emerged must be a vector") - if(is.null(index)){ - index <- seq_len(max(c(length(l.name)), c(length(r.name)))) - } - if(!(is.na(l.name[1]) & is.na(r.name[1]))){ - newConstructs <- mapply(c_makeNewConstruct, NA, - l.name=l.name, l.preferred=l.preferred, l.emerged=l.emerged, - r.name=r.name, r.preferred=r.preferred, r.emerged=r.emerged, - SIMPLIFY=FALSE) # generate new construct list - x@constructs[index] <- newConstructs - } - x -} -# x <- makeEmptyRepgrid() -# x <- c.setConstructs(x, l.name=c("construct left 1", "construct left 2")) -# x <- c.setConstructs(x, l.n=c("construct left 3", "construct left 4"), index=3:4) -# str(x@constructs, m=3) - - -# internal: c_addConstruct adds constructs at the bottom -c_addConstruct <- function(x, l.name=NA, l.preferred=NA, l.emerged=NA, - r.name=NA, r.preferred=NA, r.emerged=NA, - position=NA, side="pre"){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(!is.numeric(position) & !(length(position)==1 & is.na(position[1]))) - stop("position must be numeric.") - if(position<0 | position>length(x@constructs)+1) - stop("USERINFO: position must be between 1 and number of constructs plus 1.") - if(length(position)==1 & is.na(position[1])) position <- length(x@constructs)+1 - constructs.old <- x@constructs - constructs.new <- mapply(c_makeNewConstruct, NA, # generate construct list - l.name=l.name, l.preferred=l.preferred, l.emerged=l.emerged, - r.name=r.name, r.preferred=r.preferred, r.emerged=r.emerged, - SIMPLIFY=FALSE) - index <- insertAt(seq_along(x@constructs), position, side=side) - x@constructs[index$index.base.new] <- constructs.old[index$index.base] - x@constructs[index$index.insert.new] <- constructs.new - x -} - -#x <- makeEmptyRepgrid() -#x <- c.setConstruct(x, l.name=c("construct left 1")) -#x <- c_addConstruct(x, l.name="construct added at the end", r.name="test", pos=1) -#x <- c_addConstructs(x, l.name="construct left inserted at position 1", pos=1) -#x <- c_addConstructs(x, l.name="construct right inserted at position 1", pos=1) -#x <- c_addConstructs(x, l.name=c("construct 10", "element 11"), pos=10:11) -#str(x@constructs, m=3) - - - -# internal: c_addConstructs. all elements that do not have a position specified are added at the end -c_addConstructs <- function(x, l.name=NA, l.preferred=NA, l.emerged=NA, - r.name=NA, r.preferred=NA, r.emerged=NA, - position=NA, side="pre"){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(!is.numeric(position) & !(length(position)==1 & is.na(position[1]))) - stop("position must be numeric.") - len <- max(c(length(l.name), length(r.name))) - if(length(position)==1 & is.na(position[1])){ - position <- rep(NA, len) - } - position[is.na(position)] <- seq_along(position[is.na(position)]) + length(x@constructs) - constructs.old <- x@constructs - constructs.new <- mapply(c_makeNewConstruct, NA, # generate construct list - l.name=l.name, l.preferred=l.preferred, l.emerged=l.emerged, - r.name=r.name, r.preferred=r.preferred, r.emerged=r.emerged, - SIMPLIFY=FALSE) - index <- insertAt(seq_along(x@constructs), position, side=side) - x@constructs[index$index.base.new] <- constructs.old[index$index.base] - x@constructs[index$index.insert.new] <- constructs.new - x -} -### NOT RUN -#x <- makeEmptyRepgrid() -#x <- c.setConstructs(x, l.name=c("construct left 1", "construct left 2")) -#x <- c_addConstructs(x, l.name="construct added at the end") -#x <- c_addConstructs(x, l.name="construct left inserted at position 1", pos=1) -#x <- c_addConstructs(x, l.name="construct right inserted at position 1", pos=1) -#x <- c_addConstructs(x, l.name=c("construct 10", "element 11"), pos=10:11) -#str(x@constructs, m=3) - - - - - - - - - - - - -### maybe unnecessary functions ### - -# c.removeNullConstructs <- function(x){ -# if(!inherits(x, "repgrid")) # check if x is repgrid object -# stop("Object x must be of class 'repgrid'.") -# x@constructs <- x@constructs[!sapply(x@constructs, is.null)] -# x -# } - - - - +#----------------------------------------------# +### basic construct operations ### +#----------------------------------------------# + +# Function that start with c. operate on the constructs only. +# These functions serve for basic operations on constructs. +# In case a function needs to operate on constructs and other +# slots (e.g. elements, ratings) higher-level functions +# that perform joints operations are used. The base operations +# are not needed when using openrepgrid by the user. + +## constructs +# add constructs +# delete constructs +# rename pole(s) +# change construct order +# set pole status (emerged, preferred etc.) +# reverse poles + +# pole--+ +# +--name +# +--preferred +# +--emerged + + + +############## FUNCTIONS TO RETRIEVE INFORMATION FROM REPGRID OBJECTS ################## + +#' Get construct names +#' +#' @param x `repgrid` object. +#' @section Deprecated functions: `getConstructNames()`, +#' and `cNames()` have been deprecated. +#' Instead use `constructs()`. +#' @export +#' @keywords internal +#' +getConstructNames <- function(x) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + + l <- lapply(x@constructs, function(x) { + data.frame( + leftpole = x$leftpole$name, + rightpole = x$rightpole$name, stringsAsFactors = FALSE + ) + }) + list_to_dataframe(l) +} +cNames <- getConstructNames + + +#' Retrieves the construct names from a `repgrid`. +#' +#' Different features like trimming, indexing and choices of separators +#' allow to return the kind of format that is needed. +#' +#' @title Retrieve construct names in needed format. +#' +#' @param x `repgrid` object. +#' @param mode Type of output. 1= left and right pole +#' separated by `sep`), 2= only left pole, +#' 3 = only right pole. +#' @param trim Number of characters to trim the construct names to +#' (default `NA`). `NA` will suppress trimming. +#' The length of `index` is not included in the +#' trimming. +#' @param index Logical. Whether to add a index number before the construct +#' names (default `TRUE`). +#' @param sep Separator string between poles. +#' @param pre String before index number (default `(`). +#' @param post String after index number (default `) `). +#' @return Vector with construct names. +#' @export +#' @keywords internal +#' @examples \dontrun{ +#' +#' getConstructNames2(bell2010) +#' getConstructNames2(bell2010, mode = 2) +#' getConstructNames2(bell2010, index = T) +#' getConstructNames2(bell2010, index = T, mode = 3) +#' } +#' +getConstructNames2 <- function(x, mode = 1, trim = 20, index = F, + sep = " - ", pre = "(", post = ") ") { + if (!inherits(x, "repgrid")) { + stop("Object x must be of class 'repgrid'") + } + + cnames <- constructs(x) + cnames.l <- cnames[, 1] + cnames.r <- cnames[, 2] + + # add numeric index in front of constructs + if (index) { + ind <- paste(pre, seq_along(cnames.l), post, sep = "") + } else { + ind <- "" + } + + # trim names if prompted + if (!is.na(trim)) { + if (mode == 1) { # adjust trimming length if both sides are included + trim <- ceiling(trim / 2) + } + cnames.l <- substr(cnames.l, 1, trim) + cnames.r <- substr(cnames.r, 1, trim) + } + + if (mode == 1) { # left and right poles + cnames.new <- paste(ind, cnames.l, sep, cnames.r, sep = "") + } + if (mode == 2) { # left pole only + cnames.new <- paste(ind, cnames.l, sep = "") + } + if (mode == 3) { # right pole only + cnames.new <- paste(ind, cnames.r, sep = "") + } + cnames.new +} + + +#' Get or replace construct poles +#' +#' Allows to get and set construct poles. +#' Replaces the older functions `getConstructNames`, `getConstructNames2`, +#' and `eNames` which are deprecated. +#' +#' @param x A repgrid object. +#' @param i,j Row and column Index of repgrid matrix. +#' @param value Character vector of poles. +#' @param collapse Return vector with both poles instead. +#' @param sep Separator if `collapse = TRUE`, default is `" - "`. +#' @rdname constructs +#' @export +#' +#' @examples +#' +#' # shorten object name +#' x <- boeker +#' +#' ## get construct poles +#' constructs(x) # both left and right poles +#' leftpoles(x) # left poles only +#' rightpoles(x) +#' constructs(x, collapse = TRUE) +#' +#' ## replace construct poles +#' constructs(x)[1, 1] <- "left pole 1" +#' constructs(x)[1, "leftpole"] <- "left pole 1" # alternative +#' constructs(x)[1:3, 2] <- paste("right pole", 1:3) +#' constructs(x)[1:3, "rightpole"] <- paste("right pole", 1:3) # alternative +#' constructs(x)[4, 1:2] <- c("left pole 4", "right pole 4") +#' +#' l <- leftpoles(x) +#' leftpoles(x) <- sample(l) # brind poles into random order +#' leftpoles(x)[1] <- "new left pole 1" # replace name of first left pole +#' +#' # replace left poles of constructs 1 and 3 +#' leftpoles(x)[c(1, 3)] <- c("new left pole 1", "new left pole 3") +#' +constructs <- function(x, collapse = FALSE, sep = " - ") { + # check if x is a repgrid object + if (!inherits(x, "repgrid")) { + stop("Object x must be of class 'repgrid'.") + } + + # get left and right pole name properties from each construct + df <- data.frame( + leftpole = leftpoles(x), + rightpole = rightpoles(x), + stringsAsFactors = FALSE + ) + if (collapse) { + res <- paste0(df$leftpole, sep, df$rightpole) + return(res) + } + df +} + + +#' @rdname constructs +#' @export +`constructs<-` <- function(x, i, j, value) { + # check if x is a repgrid object + if (!inherits(x, "repgrid")) { + stop("Object x must be of class 'repgrid'.") + } + + # get dataframe and replace using bracket operator + # this replacement type function somehow works. + # Other attempts falied. + d <- constructs(x) + d[i, j] <- value + + # replace left and right poles + leftpoles(x) <- d$leftpole + rightpoles(x) <- d$rightpole + + x +} + + +#' @rdname constructs +#' @export +leftpoles <- function(x) { + # check if x is a repgrid object + if (!inherits(x, "repgrid")) { + stop("Object x must be of class 'repgrid'.") + } + + # get left pole name property from each construct + sapply(x@constructs, function(x) x$leftpole$name) +} + + +#' @param position Index where to insert construct +#' @param value Character vector of construct poles names. +#' @rdname constructs +#' @export +`leftpoles<-` <- function(x, position, value) { + # check if x is a repgrid object + if (!inherits(x, "repgrid")) { + stop("Object x must be of class 'repgrid'.") + } + + # get element names and replace one or more + p <- leftpoles(x) + p[position] <- value + + # replace leftpole name property of each construct + for (i in seq_along(p)) { + x@constructs[[i]]$leftpole$name <- p[i] + } + + x +} + +#' @rdname constructs +#' @export +rightpoles <- function(x) { + # check if x is a repgrid object + if (!inherits(x, "repgrid")) { + stop("Object x must be of class 'repgrid'.") + } + + # get left pole name property from each construct + sapply(x@constructs, function(x) x$rightpole$name) +} + +#' @rdname constructs +#' @export +`rightpoles<-` <- function(x, position, value) { + # check if x is a repgrid object + if (!inherits(x, "repgrid")) { + stop("Object x must be of class 'repgrid'.") + } + + # get element names and replace one or more + p <- rightpoles(x) + p[position] <- value + + # replace leftpole name property of each construct + for (i in seq_along(p)) { + x@constructs[[i]]$rightpole$name <- p[i] + } + + x +} + + + +constructInfo <- function(x, all = TRUE) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + l <- lapply(x@constructs, function(x) { + data.frame( + leftpole = x$leftpole$name, + l.preffered = x$leftpole$preferred, + l.emerged = x$leftpole$emerged, + rightpole = x$rightpole$name, + r.preffered = x$rightpole$preferred, + r.emerged = x$rightpole$emerged, + stringsAsFactors = FALSE + ) + }) + info <- list_to_dataframe(l) # old version using lapply above + if (all) { + info + } else { + info[c("leftpole", "rightpole")] + } +} +cInfo <- constructInfo +# constructInfo(x) + + +getNoOfConstructs <- function(x) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + length(x@constructs) +} +nc <- getNoOfConstructs + + + + +# internal. c_makeNewConstruct is the constructor for construct object (simple list) +c_makeNewConstruct <- function(x = NULL, l.name = NA, l.preferred = NA, l.emerged = NA, + r.name = NA, r.preferred = NA, r.emerged = NA, ...) { + list( + leftpole = list( + name = l.name, + preferred = l.preferred, + emerged = l.emerged + ), + rightpole = list( + name = r.name, + preferred = r.preferred, + emerged = r.emerged + ) + ) +} +# str(c_makeNewConstruct()) + + + +# internal: c.setConstructs sets constructs by index +c.setConstructs <- function(x, l.name = NA, l.preferred = NA, l.emerged = NA, + r.name = NA, r.preferred = NA, r.emerged = NA, + index = NULL, ...) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (!is.atomic(l.name) | !is.atomic(l.name)) { + stop("arguments l.name and r.name must be a vector") + } + if (!is.logical(c(l.preferred, l.emerged, r.preferred, r.emerged))) { + stop("arguments l.preferred, r.preferred, l.emerged and r.emerged must be a vector") + } + if (is.null(index)) { + index <- seq_len(max(c(length(l.name)), c(length(r.name)))) + } + if (!(is.na(l.name[1]) & is.na(r.name[1]))) { + newConstructs <- mapply(c_makeNewConstruct, NA, + l.name = l.name, l.preferred = l.preferred, l.emerged = l.emerged, + r.name = r.name, r.preferred = r.preferred, r.emerged = r.emerged, + SIMPLIFY = FALSE + ) # generate new construct list + x@constructs[index] <- newConstructs + } + x +} +# x <- makeEmptyRepgrid() +# x <- c.setConstructs(x, l.name=c("construct left 1", "construct left 2")) +# x <- c.setConstructs(x, l.n=c("construct left 3", "construct left 4"), index=3:4) +# str(x@constructs, m=3) + + +# internal: c_addConstruct adds constructs at the bottom +c_addConstruct <- function(x, l.name = NA, l.preferred = NA, l.emerged = NA, + r.name = NA, r.preferred = NA, r.emerged = NA, + position = NA, side = "pre") { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (!is.numeric(position) & !(length(position) == 1 & is.na(position[1]))) { + stop("position must be numeric.") + } + if (position < 0 | position > length(x@constructs) + 1) { + stop("USERINFO: position must be between 1 and number of constructs plus 1.") + } + if (length(position) == 1 & is.na(position[1])) position <- length(x@constructs) + 1 + constructs.old <- x@constructs + constructs.new <- mapply(c_makeNewConstruct, NA, # generate construct list + l.name = l.name, l.preferred = l.preferred, l.emerged = l.emerged, + r.name = r.name, r.preferred = r.preferred, r.emerged = r.emerged, + SIMPLIFY = FALSE + ) + index <- insertAt(seq_along(x@constructs), position, side = side) + x@constructs[index$index.base.new] <- constructs.old[index$index.base] + x@constructs[index$index.insert.new] <- constructs.new + x +} + +# x <- makeEmptyRepgrid() +# x <- c.setConstruct(x, l.name=c("construct left 1")) +# x <- c_addConstruct(x, l.name="construct added at the end", r.name="test", pos=1) +# x <- c_addConstructs(x, l.name="construct left inserted at position 1", pos=1) +# x <- c_addConstructs(x, l.name="construct right inserted at position 1", pos=1) +# x <- c_addConstructs(x, l.name=c("construct 10", "element 11"), pos=10:11) +# str(x@constructs, m=3) + + + +# internal: c_addConstructs. all elements that do not have a position specified are added at the end +c_addConstructs <- function(x, l.name = NA, l.preferred = NA, l.emerged = NA, + r.name = NA, r.preferred = NA, r.emerged = NA, + position = NA, side = "pre") { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (!is.numeric(position) & !(length(position) == 1 & is.na(position[1]))) { + stop("position must be numeric.") + } + len <- max(c(length(l.name), length(r.name))) + if (length(position) == 1 & is.na(position[1])) { + position <- rep(NA, len) + } + position[is.na(position)] <- seq_along(position[is.na(position)]) + length(x@constructs) + constructs.old <- x@constructs + constructs.new <- mapply(c_makeNewConstruct, NA, # generate construct list + l.name = l.name, l.preferred = l.preferred, l.emerged = l.emerged, + r.name = r.name, r.preferred = r.preferred, r.emerged = r.emerged, + SIMPLIFY = FALSE + ) + index <- insertAt(seq_along(x@constructs), position, side = side) + x@constructs[index$index.base.new] <- constructs.old[index$index.base] + x@constructs[index$index.insert.new] <- constructs.new + x +} +### NOT RUN +# x <- makeEmptyRepgrid() +# x <- c.setConstructs(x, l.name=c("construct left 1", "construct left 2")) +# x <- c_addConstructs(x, l.name="construct added at the end") +# x <- c_addConstructs(x, l.name="construct left inserted at position 1", pos=1) +# x <- c_addConstructs(x, l.name="construct right inserted at position 1", pos=1) +# x <- c_addConstructs(x, l.name=c("construct 10", "element 11"), pos=10:11) +# str(x@constructs, m=3) + + + + + + + + + + + + +### maybe unnecessary functions ### + +# c.removeNullConstructs <- function(x){ +# if(!inherits(x, "repgrid")) # check if x is repgrid object +# stop("Object x must be of class 'repgrid'.") +# x@constructs <- x@constructs[!sapply(x@constructs, is.null)] +# x +# } diff --git a/R/repgrid-elements.r b/R/repgrid-elements.r index 49ef750c..f82c325d 100644 --- a/R/repgrid-elements.r +++ b/R/repgrid-elements.r @@ -1,298 +1,314 @@ -#----------------------------------------------# -### basic element operations ### -#----------------------------------------------# - -# Function that start with e. operate on the elements only. -# These functions serve for basic operations on elements. -# In case a function needs to operate on elements and other -# slots (e.g. constructs, ratings) higher-level functions -# that perform joints operations are used. The base operations -# are not needed when using openrepgrid. Only in case the user wants to -# create new functions they will be needed. - -### basic functions: -# ------------------------- # -# add elements -# delete elements -# rename elements (full and abbreviated names) -# set elememt status (ideal) -# change element order - - -############## FUNCTIONS TO RETRIEVE INFORMATION FROM REPGRID OBJECTS ################## - -# internal: retrieve element slot. For convenience, so new users do not have to deal with object slots -# as they will not have knowledge of object structures (S3, S4). -getElements <- function(x){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - x@elements -} - - -#' Retrieve element names of repgrid object. -#' -#' Function for convenience, so new users do not have to deal with object slots -#' as they will typically not have knowledge about R object structures (S3, S4). -#' -#' @param x `repgrid` object. -#' @return vector Vector containing the names of the elements. -#' @section Deprecated functions: `getElementNames()`, -#' `getElementNames2()`, and `eNames()` have been deprecated. -#' Instead use `elements()`. -#' @export -#' @keywords internal -#' -getElementNames <- function(x) -{ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - - .Deprecated("elements") - - sapply(x@elements, function(x) x$name) -} -eNames <- getElementNames - -## sample code -# rg1 <- makeEmptyRepgrid() -# rg1 <- setElements(rg1, LETTERS[1:5]) -# getElements(rg1) -# getElementNames(rg1) - - - - -#' Retrieves the element names from a `repgrid`. -#' -#' Different features like trimming, indexing and choices of separators -#' allow to return the kind of format that is needed. -#' -#' @title Retrieve element names in needed format. -#' -#' @param x `repgrid` object. -#' @param trim Number of characters to trim the construct names to -#' (default `NA`). `NA` will suppress trimming. -#' The length of `index` is not included in the -#' trimming. -#' @param index Logical. Whether to add a index number before the construct -#' names (default `TRUE`). -#' @param pre String before index number (default `(`). -#' @param post String after index number (default `) `). -#' @return Vector with (trimmed) element names. -#' @export -#' @keywords internal -#' @examples \dontrun{ -#' -#' getElementNames2(bell2010) -#' getElementNames2(bell2010, mode=2) -#' getElementNames2(bell2010, index=T) -#' getElementNames2(bell2010, index=T, trim=30) -#' -#' } -#' -getElementNames2 <- function(x, trim=20, index=F, - pre="(", post=") " ){ - if (!inherits(x, "repgrid")) - stop("Object x must be of class 'repgrid'") - - enames <- elements(x) - - # add numeric index in front of elements - if (index) - ind <- paste(pre, seq_along(enames), post, sep="") else - ind <- "" - - # trim names if prompted - if (!is.na(trim)){ - enames <- substr(enames, 1, trim) - } - - enames.new <- paste(ind, enames, sep="") - enames.new -} - - - - -#' Get or replace element names -#' -#' Allows to get and set element names. -#' Replaces the older functions `getElementNames`, `getElementNames2`, -#' and `eNames` which are deprecated. -#' -#' @param x A repgrid object. -#' @rdname elements -#' @export -#' @examples -#' -#' # copy Boeker grid to x -#' x <- boeker -#' -#' ## get element names -#' e <- elements(x) -#' e -#' -#' ## replace element names -#' elements(x) <- rev(e) # reverse all element names -#' elements(x)[1] <- "Hannes" # replace name of first element -#' -#' # replace names of elements 1 and 3 -#' elements(x)[c(1,3)] <- c("element 1", "element 3") -#' -elements <- function(x) -{ - # check if x is a repgrid object - if (!inherits(x, "repgrid")) - stop("Object x must be of class 'repgrid'.") - - # get name property from each element - sapply(x@elements, function(x) x$name) -} - - -#' @param position Index where to insert element. -#' @param value Character vector of element names. -#' @rdname elements -#' @export -#' -`elements<-` <- function(x, position, value) -{ - # check if x is a repgrid object - if (!inherits(x, "repgrid")) - stop("Object x must be of class 'repgrid'.") - - # get element names and replace one or more - e.names <- elements(x) - e.names[position] <- value - - # replace name propert of each element - for (i in seq_along(e.names)) { - x@elements[[i]]$name <- e.names[i] - } - - x -} - - -getNoOfElements <- function(x){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - length(x@elements) -} -# getNoOfElements(rg1) - - -# internal: e.makeNewElement makes a new element object which is simply list with certain standard -# entries -e.makeNewElement <- function(x=NULL, name=NA, abbreviation=NA, status=NA){ - list(name=name, - abbreviation=abbreviation, - status=status) -} - - -# internal: e.setElements sets one or more elements in the grid. The index defines the column where the -# element is added. -e.setElements <- function(x, name=NA, abbreviation=NA, status=NA, index=NULL, ...){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(!is.atomic(name) | !is.atomic(abbreviation) | !is.atomic(status)) # if elements comes as a vector - stop("arguments name, abbreviation and status must be a vector") - if(is.null(index)){ - index <- seq_len(max(c(length(name), length(abbreviation), length(status)))) - } - if(length(index)!=max(c(length(name), length(abbreviation), length(status)))) - stop("length of index values differ from number of elements provided.") - if(length(unique(index)) != length(index)) # is index unique? - stop("index values must be unique.") - new.elements <- index[index > length(x@elements)] # elements that are replaced - replaced.elements <- index[index <= length(x@elements)] # elements that are added - if(max(index) > (length(x@elements) + length(new.elements))) # wholes in element list if added at an index that is not succesive (e.g. 1,2,5)? - stop("index has values that will create wholes in the element list.") - if(!(is.na(name[1]) & is.na(abbreviation[1]) & is.na(status[1])) ){ - newElements <- mapply(e.makeNewElement, "dummy", name=name, abb=abbreviation, status=status, SIMPLIFY=FALSE) # generate new element list - x@elements[index] <- newElements - } - # add no of columns in ratings array if element is added: TODO? -> in higher-order function in repgrid-basicops - x -} -# x <- makeEmptyRepgrid() -# x <- e.setElements(x, name=c("element 1", "element 2"), abb=c("e1","e2"), i=2:1) -# x <- e.setElements(x, name=c("element 3", "element 4"), abb=c("e3","e4"), index=3:4) -# x <- makeEmptyRepgrid() -# x <- e.setElements(x, name="test") -# x <- e.setElements(x, name="test", index=3) # error due to wholes in element list - - - -# internal: e.addElements adds elements to the grid. All elements that do not have -# a position specified are added at the end. -e.addElements <- function(x, name=NA, abbreviation=NA, status=NA, position=NA, side="pre"){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if (!is.numeric(position) & !(length(position) == 1 & is.na(position[1]))) - stop("position must be numeric.") - len <- max(c(length(name), length(abbreviation), length(status))) - if (length(position) == 1 & is.na(position[1])) - position <- rep(NA, len) - if (length(unique(position)) != length(position) & ! all(is.na(position))) # is index unique? - stop("position values must be unique.") - position[is.na(position)] <- seq_along(position[is.na(position)]) + length(x@elements) - elements.old <- x@elements - elements.new <- mapply(e.makeNewElement, NA, name=name, abb=abbreviation, status=status, SIMPLIFY=FALSE) # generate new element list - index <- insertAt(seq_along(x@elements), position, side=side) - tmp <- c(index$index.base.new, index$index.insert.new) - if (max(tmp) > length(tmp)) - stop("position has values that will create wholes in the element list.") - x@elements[index$index.base.new] <- elements.old[index$index.base] - x@elements[index$index.insert.new] <- elements.new - x -} -### NOT RUN -# x <- makeEmptyRepgrid() -# x <- e.setElements(x, name=c("element 1", "element 2"), abb=c("e1","e2")) -# x <- e.addElements(x, name="element added at the end") -#x <- e.addElements(x, name="element inserted at position 1", pos=1) -#x <- e.addElements(x, name=c("element A", "element B"), abb=c("e1","e2"), pos=5:6) -#x <- e.addElements(x, name=c("element A", "element B"), abb=c("e1","e2"), pos=10:11) -#x <- e.addElements(x, name=c("element C", "element D"), abb=c("eA","eB"), pos=c(1,1)) # todo geht nicht - -#x <- makeEmptyRepgrid() -#x <- addElements(x, name=c("element 1", "element 2"), abb=c("e1","e2")) -#insertAt(numeric(0), 1:2) - - - - - - - - - - -### maybe unnecessary functions ### - -# internal: e.removeNullElements removes non exsiting elements -# TODO: might already be unnecessary as NULL elements should not be allowed -# e.removeNullElements <- function(x){ -# if(!inherits(x, "repgrid")) # check if x is repgrid object -# stop("Object x must be of class 'repgrid'.") -# x@elements <- x@elements[!sapply(x@elements, is.null)] -# x -# } - -# internal: e.deleteElements to delete specific element -# e.deleteElements <- function(x, pos){ -# if(!inherits(x, "repgrid")) # check if x is repgrid object -# stop("Object x must be of class 'repgrid'.") -# if(any(pos<0 | pos > getNoOfElements(x))) -# stop("pos must contain values greater than 1 and equal or less than number of elements.") -# x@elements <- x@elements[-pos] -# x -# } -# x <- makeEmptyRepgrid() -# x <- addElements(x, name=c("element 1", "element 2"), abb=c("e1","e2")) -# str(x) -# x <- deleteElements(x, 1) -# str(x) +#----------------------------------------------# +### basic element operations ### +#----------------------------------------------# + +# Function that start with e. operate on the elements only. +# These functions serve for basic operations on elements. +# In case a function needs to operate on elements and other +# slots (e.g. constructs, ratings) higher-level functions +# that perform joints operations are used. The base operations +# are not needed when using openrepgrid. Only in case the user wants to +# create new functions they will be needed. + +### basic functions: +# ------------------------- # +# add elements +# delete elements +# rename elements (full and abbreviated names) +# set elememt status (ideal) +# change element order + + +############## FUNCTIONS TO RETRIEVE INFORMATION FROM REPGRID OBJECTS ################## + +# internal: retrieve element slot. For convenience, so new users do not have to deal with object slots +# as they will not have knowledge of object structures (S3, S4). +getElements <- function(x) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + x@elements +} + + +#' Retrieve element names of repgrid object. +#' +#' Function for convenience, so new users do not have to deal with object slots +#' as they will typically not have knowledge about R object structures (S3, S4). +#' +#' @param x `repgrid` object. +#' @return vector Vector containing the names of the elements. +#' @section Deprecated functions: `getElementNames()`, +#' `getElementNames2()`, and `eNames()` have been deprecated. +#' Instead use `elements()`. +#' @export +#' @keywords internal +#' +getElementNames <- function(x) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + + .Deprecated("elements") + + sapply(x@elements, function(x) x$name) +} +eNames <- getElementNames + +## sample code +# rg1 <- makeEmptyRepgrid() +# rg1 <- setElements(rg1, LETTERS[1:5]) +# getElements(rg1) +# getElementNames(rg1) + + + + +#' Retrieves the element names from a `repgrid`. +#' +#' Different features like trimming, indexing and choices of separators +#' allow to return the kind of format that is needed. +#' +#' @title Retrieve element names in needed format. +#' +#' @param x `repgrid` object. +#' @param trim Number of characters to trim the construct names to +#' (default `NA`). `NA` will suppress trimming. +#' The length of `index` is not included in the +#' trimming. +#' @param index Logical. Whether to add a index number before the construct +#' names (default `TRUE`). +#' @param pre String before index number (default `(`). +#' @param post String after index number (default `) `). +#' @return Vector with (trimmed) element names. +#' @export +#' @keywords internal +#' @examples \dontrun{ +#' +#' getElementNames2(bell2010) +#' getElementNames2(bell2010, mode = 2) +#' getElementNames2(bell2010, index = T) +#' getElementNames2(bell2010, index = T, trim = 30) +#' } +#' +getElementNames2 <- function(x, trim = 20, index = F, + pre = "(", post = ") ") { + if (!inherits(x, "repgrid")) { + stop("Object x must be of class 'repgrid'") + } + + enames <- elements(x) + + # add numeric index in front of elements + if (index) { + ind <- paste(pre, seq_along(enames), post, sep = "") + } else { + ind <- "" + } + + # trim names if prompted + if (!is.na(trim)) { + enames <- substr(enames, 1, trim) + } + + enames.new <- paste(ind, enames, sep = "") + enames.new +} + + + + +#' Get or replace element names +#' +#' Allows to get and set element names. +#' Replaces the older functions `getElementNames`, `getElementNames2`, +#' and `eNames` which are deprecated. +#' +#' @param x A repgrid object. +#' @rdname elements +#' @export +#' @examples +#' +#' # copy Boeker grid to x +#' x <- boeker +#' +#' ## get element names +#' e <- elements(x) +#' e +#' +#' ## replace element names +#' elements(x) <- rev(e) # reverse all element names +#' elements(x)[1] <- "Hannes" # replace name of first element +#' +#' # replace names of elements 1 and 3 +#' elements(x)[c(1, 3)] <- c("element 1", "element 3") +#' +elements <- function(x) { + # check if x is a repgrid object + if (!inherits(x, "repgrid")) { + stop("Object x must be of class 'repgrid'.") + } + + # get name property from each element + sapply(x@elements, function(x) x$name) +} + + +#' @param position Index where to insert element. +#' @param value Character vector of element names. +#' @rdname elements +#' @export +#' +`elements<-` <- function(x, position, value) { + # check if x is a repgrid object + if (!inherits(x, "repgrid")) { + stop("Object x must be of class 'repgrid'.") + } + + # get element names and replace one or more + e.names <- elements(x) + e.names[position] <- value + + # replace name propert of each element + for (i in seq_along(e.names)) { + x@elements[[i]]$name <- e.names[i] + } + + x +} + + +getNoOfElements <- function(x) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + length(x@elements) +} +# getNoOfElements(rg1) + + +# internal: e.makeNewElement makes a new element object which is simply list with certain standard +# entries +e.makeNewElement <- function(x = NULL, name = NA, abbreviation = NA, status = NA) { + list( + name = name, + abbreviation = abbreviation, + status = status + ) +} + + +# internal: e.setElements sets one or more elements in the grid. The index defines the column where the +# element is added. +e.setElements <- function(x, name = NA, abbreviation = NA, status = NA, index = NULL, ...) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (!is.atomic(name) | !is.atomic(abbreviation) | !is.atomic(status)) { # if elements comes as a vector + stop("arguments name, abbreviation and status must be a vector") + } + if (is.null(index)) { + index <- seq_len(max(c(length(name), length(abbreviation), length(status)))) + } + if (length(index) != max(c(length(name), length(abbreviation), length(status)))) { + stop("length of index values differ from number of elements provided.") + } + if (length(unique(index)) != length(index)) { # is index unique? + stop("index values must be unique.") + } + new.elements <- index[index > length(x@elements)] # elements that are replaced + replaced.elements <- index[index <= length(x@elements)] # elements that are added + if (max(index) > (length(x@elements) + length(new.elements))) { # wholes in element list if added at an index that is not succesive (e.g. 1,2,5)? + stop("index has values that will create wholes in the element list.") + } + if (!(is.na(name[1]) & is.na(abbreviation[1]) & is.na(status[1]))) { + newElements <- mapply(e.makeNewElement, "dummy", name = name, abb = abbreviation, status = status, SIMPLIFY = FALSE) # generate new element list + x@elements[index] <- newElements + } + # add no of columns in ratings array if element is added: TODO? -> in higher-order function in repgrid-basicops + x +} +# x <- makeEmptyRepgrid() +# x <- e.setElements(x, name=c("element 1", "element 2"), abb=c("e1","e2"), i=2:1) +# x <- e.setElements(x, name=c("element 3", "element 4"), abb=c("e3","e4"), index=3:4) +# x <- makeEmptyRepgrid() +# x <- e.setElements(x, name="test") +# x <- e.setElements(x, name="test", index=3) # error due to wholes in element list + + + +# internal: e.addElements adds elements to the grid. All elements that do not have +# a position specified are added at the end. +e.addElements <- function(x, name = NA, abbreviation = NA, status = NA, position = NA, side = "pre") { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (!is.numeric(position) & !(length(position) == 1 & is.na(position[1]))) { + stop("position must be numeric.") + } + len <- max(c(length(name), length(abbreviation), length(status))) + if (length(position) == 1 & is.na(position[1])) { + position <- rep(NA, len) + } + if (length(unique(position)) != length(position) & !all(is.na(position))) { # is index unique? + stop("position values must be unique.") + } + position[is.na(position)] <- seq_along(position[is.na(position)]) + length(x@elements) + elements.old <- x@elements + elements.new <- mapply(e.makeNewElement, NA, name = name, abb = abbreviation, status = status, SIMPLIFY = FALSE) # generate new element list + index <- insertAt(seq_along(x@elements), position, side = side) + tmp <- c(index$index.base.new, index$index.insert.new) + if (max(tmp) > length(tmp)) { + stop("position has values that will create wholes in the element list.") + } + x@elements[index$index.base.new] <- elements.old[index$index.base] + x@elements[index$index.insert.new] <- elements.new + x +} +### NOT RUN +# x <- makeEmptyRepgrid() +# x <- e.setElements(x, name=c("element 1", "element 2"), abb=c("e1","e2")) +# x <- e.addElements(x, name="element added at the end") +# x <- e.addElements(x, name="element inserted at position 1", pos=1) +# x <- e.addElements(x, name=c("element A", "element B"), abb=c("e1","e2"), pos=5:6) +# x <- e.addElements(x, name=c("element A", "element B"), abb=c("e1","e2"), pos=10:11) +# x <- e.addElements(x, name=c("element C", "element D"), abb=c("eA","eB"), pos=c(1,1)) # todo geht nicht + +# x <- makeEmptyRepgrid() +# x <- addElements(x, name=c("element 1", "element 2"), abb=c("e1","e2")) +# insertAt(numeric(0), 1:2) + + + + + + + + + + +### maybe unnecessary functions ### + +# internal: e.removeNullElements removes non exsiting elements +# TODO: might already be unnecessary as NULL elements should not be allowed +# e.removeNullElements <- function(x){ +# if(!inherits(x, "repgrid")) # check if x is repgrid object +# stop("Object x must be of class 'repgrid'.") +# x@elements <- x@elements[!sapply(x@elements, is.null)] +# x +# } + +# internal: e.deleteElements to delete specific element +# e.deleteElements <- function(x, pos){ +# if(!inherits(x, "repgrid")) # check if x is repgrid object +# stop("Object x must be of class 'repgrid'.") +# if(any(pos<0 | pos > getNoOfElements(x))) +# stop("pos must contain values greater than 1 and equal or less than number of elements.") +# x@elements <- x@elements[-pos] +# x +# } +# x <- makeEmptyRepgrid() +# x <- addElements(x, name=c("element 1", "element 2"), abb=c("e1","e2")) +# str(x) +# x <- deleteElements(x, 1) +# str(x) diff --git a/R/repgrid-output.r b/R/repgrid-output.r index 595f86ba..4e1d1cb1 100644 --- a/R/repgrid-output.r +++ b/R/repgrid-output.r @@ -1,546 +1,582 @@ -# trim column of a matrix to equal width -# x: matrix -trim_column_width <- function(x, just="l"){ - lengths <- apply(nchar(x), 2, max) - for (j in seq_len(ncol(x))) { - x[ ,j] <- format(x[ ,j], just = just, width = lengths[j]) - } - x -} -#trim_column_width(x, just="r") - - -collapse_matrix <- function(x, collapse="", sep=" "){ - x <- apply(x, 1, paste, - collapse = collapse, sep = sep) # collapse whole matrix - do.call(rbind, as.list(x)) # bind whole matrix together -} - - -# x: matrix -matrix_to_single_char_matrix <- function(x, collapse="", sep=" "){ - x <- collapse_matrix(x, collapse = collapse, sep = sep) - x <- sapply(x, strsplit, split = "") # split to single chars - names(x) <- NULL # for cleaner output - do.call(rbind, x) # single chars matrix -} - - -# TODO: first line indent wrong -matrix_to_console <- function(x, sep=""){ - #cat(" ") ??? - dummy <- apply(x, 1, function(x) - cat(c(x, "\n"), collapse = "", sep = sep)) -} - -widths_matrix_columns <- function(x){ - apply(x, 2, function(y) max(nchar(y))) -} - - -random_df <- function(nrow=ncol, ncol = nrow, wrow = 6, wcol = 10) { - x <- data.frame(replicate(ncol, sample(1:5, nrow, replace = TRUE))) - rownames(x) <- replicate(nrow, randomSentence(wrow)) - colnames(x) <- replicate(ncol, randomSentence(wcol)) - x -} - - -# @param x a single char matrix -# @param left number of empoty columns added on left side (default 0) -# @param right number of empty columns added at right side (default 0) -# @return matrix -# @keywords internal -add_empty_cols <- function(x, left = 0, right = 0) { - x <- cbind(matrix(" ", nrow = nrow(x), ncol = left), x) - x <- cbind(x, matrix(" ", nrow = nrow(x), ncol = right)) - x -} - - -# Binds two single character matrices of different size horizontally -# -# Two matrices in atomci format are binded horizontally at a specified -# position. The matrices need to be in single char format, i.e. one character per cell -# only. If the dimensions are different, the margins of the matrices are filled up with -# empty cells. -# -# @param um upper matrix (must be single char matrix) -# @param lm lower matrix (must be single char matrix) -# @param anchors two integers specifying at which columns matrices are aligned -# @return matrix -# -# @keywords internal -# @examples \dontrun{ -# um <- matrix("u", ncol=10, nrow=5) -# lm <- matrix("l", ncol=8, nrow=3) -# bind_matrices_horizontally(um, lm, anchors=c(3,1)) -# } -bind_matrices_horizontally <- function(um, lm, anchors = c(1,1)) { - diff.left <- diff(anchors) # add columns on left side - if (diff.left <= 0) { - um.ncols.empty.left <- 0 - lm.ncols.empty.left <- abs(diff.left) - } else { - um.ncols.empty.left <- abs(diff.left) - lm.ncols.empty.left <- 0 - } - um <- add_empty_cols(um, left = um.ncols.empty.left) - lm <- add_empty_cols(lm, left = lm.ncols.empty.left) - - diff.right <- diff(c(ncol(um), ncol(lm))) # add columns on right side - if (diff.right <= 0) { - um.ncols.empty.right <- 0 - lm.ncols.empty.right <- abs(diff.right) - } else { - um.ncols.empty.right <- abs(diff.right) - lm.ncols.empty.right <- 0 - } - um <- add_empty_cols(um, right = um.ncols.empty.right) - lm <- add_empty_cols(lm, right = lm.ncols.empty.right) - - rbind(um, lm) -} - - - -# break at any point possible -break_output <- function(mat, ncolkeep = 14, keeprows=TRUE) -{ - availchar <- options()$width # get console size (problematic update) - #print(availchar) - #if (availchar < ncolkeep) # set FALSE to avoid endless recursion - # keeprows <- FALSE - if (ncol(mat) >= availchar) { - mat.tmp <- mat[ , 1:(availchar - 1)] - out.tmp <- collapse_matrix(mat.tmp, collapse = "") # collapse rows - matrix_to_console(out.tmp) # print first part to console - cat("\n") # empty line after print out to separate prints - # if (keeprows) { # rownames after each pagebreak? - # mat.residual <- mat[ , c(1:(ncolkeep), availchar:ncol(mat))] - # } else { - mat.residual <- mat[ , c(availchar:ncol(mat)), drop = FALSE] - #} - Recall(mat.residual) # recursive output call - } else { - out <- collapse_matrix(mat, collapse = "") # collapse rows - matrix_to_console(out) # print to console - } -} - -trim_string <- function(vec, trim=NA) { - if (!is.na(trim)) - vec <- substr(vec, 1, trim) - vec -} - -make_sep_mat_atomic <- function(sep, nr) { - sep.atomic <- strsplit(sep, "")[[1]] - matrix(sep.atomic, nrow = nr, - ncol = nchar(sep), byrow = TRUE) -} - - - -#' Colorize matrix cell rows using crayon colors -#' -#' Atomic matrices can be wrapped into crayon color codes without -#' destroying the structure or alignment. Used to indicate -#' preferred poles. -#' -#' @param m A matrix. -#' @param colors crayon colors as a string. One of -#' black, red, green, yellow, blue, magenta, cyan, white, -#' silver. -#' @export -#' @keywords internal -#' @examples -#' m <- as.matrix(mtcars) -#' colorize_matrix_rows(m, "red") -#' -colorize_matrix_rows <- function(m, colors = "white", na.val = "white") -{ - if (!crayon::has_color()) - return(m) - - nr <- nrow(m) - if (length(colors) == 1) - colors <- rep(colors, nr) - if (length(colors) != nr) - stop("Length of colors must match number of matrix rows", call. = FALSE) - - # colorize by row - colors[is.na(colors)] <- na.val - cc <- colors %in% c("black", "red", "green", "yellow", "blue", "magenta", "cyan", "white", "silver") - if (!all(cc)) - stop("Only crayon colors are allowed", call. = FALSE) - - ii <- seq_len(nr) - for (i in ii) { - color_fun <- match.fun(colors[i]) - m[i, ] <- color_fun(m[i, ]) - } - m -} - - -df_out <- function(df, # data frame - left=NA, # rows left - right=NA, # rows right - showopt=1, # options where to place left and right matrix - # 0=none, 1 = left and right, 2= both left, 3=both right - just.rows="r", # justification of row names - just.main="l", # justification of body - max.char.rows=200, # max no of chars of row names to be printed - sep=" ", # separator symbol between columns - sep2=" ", # separator between row names and first column - equal=FALSE, # equal width for columns (max column width) - prefix="", # optional prefix before printed column name - # (e.g. "+---"). characters - keeprows=T, # whether to show rows after each pagebreak - colstart="l", - margin=1, # right margin for linebreak - trim=c(NA,NA), # maximum number of character for r/c entry. - cut=c(NA, NA), # maximal number of chars left and right of main matrix - id=c(T,T), # id numbers at beginning/end of each row/column - hatform=FALSE) # column names in hat form -{ - # sanity checks - if (length(trim) == 1) # if only one parameter given, extend to the other - trim <- recycle(trim, 2) - if (length(cut) == 1) - cut <- recycle(cut, 2) - if (length(id) == 1) - id <- recycle(id, 2) - if (!identical(left, NA) & !identical(right, NA)) { - if (length(left) != length(right)) - stop("left and right must have the same length") - if (length(left) != nrow(df) | length(right) != nrow(df)) - stop("left and/or right must equal number of rows in df") - } - - # main matrix mat.m - make_mat_main <- function(df) { - mat.m <- sapply(df, as.character) # convert to character for type security - rownames(mat.m) <- NULL # unnecessary - colnames(mat.m) <- NULL # unnecessary - mat.m <- as.matrix(mat.m) # convert to matrix, - if (nrow(df) == 1) # re-transpose in single row case - mat.m <- t(mat.m) - nchar.column <- widths_matrix_columns(mat.m) # no of chars per column - if (equal) { # equal or dynamic column width - mat.m <- format(mat.m, justify = just.main, width = max(nchar.column)) - } else { - mat.m <- trim_column_width(mat.m, just = just.main) - } - mat.m - } - - # vec vector of strings to be made as column matrix - # idside side at which id is attached (1=start, 2=end) - # trim number of chars to trim strings to - # just justification of text (l, c, r) - make_mat_leftright <- function(vec, id = TRUE, idside = 1, trim = NA, just = "r"){ - if (!is.na(trim)) # trim rownames - left <- substr(vec, 1, trim) - if (id) { # add id number to each row - ids <- paste("(", seq_along(vec), ")", sep = "") - if (idside == 1) # ids at start of string (for right side constructs) - vec <- paste(ids, vec) - else vec <- paste(vec, ids) # ids at end of string (for left side constructs) - } - vec <- format(vec, justify = just) # justify rownames - as.matrix(vec) - } - - # make left and right matrices - mat.left <- matrix("", nrow = nrow(df), ncol = 0) # default void matrix to start from - mat.right <- matrix("", nrow = nrow(df), ncol = 0) # default void matrix to start from - - if (!identical(left, NA)) # trimming occures in all cases if prompted - left <- trim_string(left, trim = trim[1]) - if (!identical(right, NA)) - right <- trim_string(right, trim = trim[1]) - leftright <- paste(left, right, sep = " - ") # join left and right strings - - # decision where and how to put left and right vectors - if (showopt == 1) { # #1 left to left, right to right - if (!identical(left, NA)) - mat.left <- make_mat_leftright(left, id = id[1], idside = 2, just = "r") - if (!identical(right, NA)) - mat.right <- make_mat_leftright(right, id = id[1], idside = 1, just = "l") - } else if (showopt == 2) { # #2 left and right on left side - if (!identical(left, NA) & !identical(right, NA)) { - mat.left <- make_mat_leftright(leftright, id = id[1], idside = 2, just = "r") - } else if (identical(left, NA) & !identical(right, NA)) { - mat.left <- make_mat_leftright(right, id = id[1], idside = 2, just = "r") - } else if (!identical(left, NA) & identical(right, NA)) { - mat.left <- make_mat_leftright(left, id = id[1], idside = 2, just = "r") - } - } else if (showopt == 3) { # #3 left and right on right side - if (!identical(left, NA) & !identical(right, NA)) { - mat.right <- make_mat_leftright(leftright, id = id[1], idside = 1, just = "l") - } else if (identical(left, NA) & !identical(right, NA)) { - mat.right <- make_mat_leftright(right, id = id[1], idside = 1, just = "l") - } else if (!identical(left, NA) & identical(right, NA)) { - mat.right <- make_mat_leftright(left, id = id[1], idside = 1, just = "l") - } - } # #0 left and right unused, mat.left and mat.right remain void - - mat.m <- make_mat_main(df) - mat.m.atomic <- matrix_to_single_char_matrix(mat.m, collapse = sep) - - mat.left.atomic <- matrix_to_single_char_matrix(mat.left) - mat.right.atomic <- matrix_to_single_char_matrix(mat.right) - - widths.columns <- widths_matrix_columns(mat.m) # vector column widths - widths.sep1 <- nchar(sep) - widths.sep2 <- nchar(sep2) - - # where to place colnames in matrix upper - columns.start.r <- cumsum(widths.columns + widths.sep1) - widths.sep1 - columns.start.l <- columns.start.r - widths.columns + 1 - columns.start.cl <- columns.start.l + floor((widths.columns + 1) / 2) - columns.start.cr <- columns.start.l + ceiling((widths.columns + 1) / 2) - - # select column start vector - if (colstart == "r") - columns.start <- columns.start.r else - if (colstart == "cl") - columns.start <- columns.start.cl else - if (colstart == "cr") - columns.start <- columns.start.cr else - columns.start <- columns.start.l - - # maximal rows of mat.u is length of column name plus starting position (plus prefix) - names.columns <- colnames(df) # extract colnames - if (!is.na(trim[2])) # trim colnames - names.columns <- substr(names.columns, 1, trim[2]) - - ### hat = FALSE (upper matrix u in descending form) - if (!hatform) { - if (id[2]) { # add id number to each col - ids <- paste(seq_along(names.columns), "-", sep = " ") - names.columns <- paste(ids, names.columns) - } - - names.columns <- paste(prefix, names.columns, sep = "") # add prefix (default "") - ncol.mat.columns <- max(columns.start + - nchar(names.columns) - 1) # min no columns mat.u - nrow.mat.columns <- length(names.columns) + 1 - mat.u.atomic <- matrix(" ", nrow = nrow.mat.columns, # empty matrix - ncol = ncol.mat.columns) - - # fill matrix upper - names.atomic.list <- strsplit(names.columns, "") - lengths.colnames <- nchar(names.columns) - for (j in seq_along(columns.start)) { # vertical lines ("|") at column starts - mat.u.atomic[(j + 1):nrow(mat.u.atomic), columns.start[j]] <- "|" - mat.u.atomic[j, columns.start[j]:(columns.start[j] + - lengths.colnames[j] - 1)] <- names.atomic.list[[j]] - } - extra.cols.left <- 0 # to suit results of hat=TRUE part - } - - ### hat = TRUE (upper matrix u in hat form) - if (hatform) { - ncol <- length(names.columns) # no of columns - midcol <- ceiling((ncol + 1) / 2) # determine middle column - index.cols.left <- 1:(midcol - 1) # index of left columns - index.cols.right <- midcol:ncol # index of right columns - colnames.left <- names.columns[index.cols.left] # left hat side - colnames.right <- names.columns[index.cols.right] # right hat side - - if (id[2]) { # add id number to each col - ids.left <- seq_along(names.columns)[index.cols.left] - ids.right <- seq_along(names.columns)[index.cols.right] - colnames.left <- paste(colnames.left, ids.left, sep = " - ") - colnames.right <- paste(ids.right, colnames.right, sep = " - ") - } - - # add prefix to both sides (default "") - colnames.left <- paste(colnames.left, strReverse(prefix), sep = "") # left side has revesred prefix - colnames.right <- paste(prefix, colnames.right, sep = "") - colnames.leftright <- c(colnames.left, colnames.right) - lengths.colnames <- nchar(colnames.leftright) - - minpos <- min(columns.start[index.cols.left] - nchar(colnames.left)) # min pos to left - maxpos <- max(columns.start[index.cols.right] + nchar(colnames.right)) # max pos to right - - if (minpos < 0 ) { - extra.cols.left <- abs(minpos) - } else { - extra.cols.left <- 0 - } - ncol.mat.upper <- extra.cols.left + maxpos # ncol of upper matrix - nrow.mat.upper <- max(c(length(colnames.left), length(colnames.right))) + 1 # nrow of upper matrix - mat.u.atomic <- matrix(" ", nrow = nrow.mat.upper, # empty upper matrix to get filled - ncol = ncol.mat.upper) - - names.atomic.list.left <- strsplit(colnames.left, "") - names.atomic.list.right <- strsplit(colnames.right, "") - names.atomic.list.leftright <- c(names.atomic.list.left, - names.atomic.list.right) - - # fill matrix u and build vertical lines for left and right side - bottom.row <- nrow(mat.u.atomic) - nc <- length(columns.start) - columns.start.offsetted <- extra.cols.left + columns.start - for (j in seq_along(columns.start)) { # vertical lines ("|") at column starts - if (j < ceiling((nc + 1) / 2)) { - mat.u.atomic[(bottom.row - j + 1):bottom.row, - columns.start.offsetted[j]] <- "|" - mat.u.atomic[(bottom.row - j), - (columns.start.offsetted[j] - lengths.colnames[j] + 1): - columns.start.offsetted[j]] <- - names.atomic.list.leftright[[j]] - } else { - mat.u.atomic[(bottom.row - (nc - j) - 1):bottom.row, - columns.start.offsetted[j]] <- "|" - mat.u.atomic[(bottom.row - (nc - j) - 1), columns.start.offsetted[j]: - (columns.start.offsetted[j] + lengths.colnames[j] - 1)] <- - names.atomic.list.leftright[[j]] - } - } # TODO: right side one row too much, maybe erase - } - - # colorize constructs by pole preference - # TODO: Extract pole preferences here - # rows <- nrow(mat.left.atomic) - # colors_ <- sample(c("red", "green", "yellow", "silver", "white"), rows, T) - mat.left.atomic <- colorize_matrix_rows(mat.left.atomic, "white") - mat.right.atomic <- colorize_matrix_rows(mat.right.atomic, "white") - - # browser() - # same part for both types - mat.sep2.atomic <- make_sep_mat_atomic(sep2, nr = nrow(df)) # matrix to separate left and main, or main and right - mat.lm.atomic <- cbind( mat.left.atomic, mat.sep2.atomic, mat.m.atomic, # lower matrix lm - mat.sep2.atomic, mat.right.atomic) - - # join upper and lower matrix - anchor.um <- extra.cols.left + 1 - anchor.lm <- ncol(mat.left.atomic) + ncol(mat.sep2.atomic) + 1 - mat.out.atomic <- bind_matrices_horizontally(mat.u.atomic, mat.lm.atomic, - anchors = c(anchor.um, anchor.lm)) - - # cut output at sides if prompted - diff.left <- diff(c(anchor.um, anchor.lm)) - if (diff.left <= 0) { - lm.empty.cols.left <- abs(diff.left) - } else { - lm.empty.cols.left <- 0 - } - start.main.at <- lm.empty.cols.left + ncol(cbind(mat.left.atomic, mat.sep2.atomic)) - end.main.at <- start.main.at + ncol(mat.m.atomic) - - if (!is.na(cut[1]) | !is.na(cut[2])) { - if (is.na(cut[1])) { - end.left <- 1 - } else { - end.left <- trim_val(start.main.at - cut[1], minmax = c(1, 200)) - } - if (is.na(cut[2])) { - end.right <- ncol(mat.out.atomic) - } else { - end.right <- trim_val(end.main.at + cut[2], - minmax = c(1, ncol(mat.out.atomic))) - } - mat.out.atomic <- mat.out.atomic[ , end.left:end.right] - } - break_output(mat.out.atomic) - invisible(NULL) -} - -#df <- random_df(10, 25, wcol=4) -#left <- randomSentences(10, 5) -#right <- randomSentences(10, 5) -#df_out(df, left, right, h=T, cut=25, id=T, show=1) - - - -# Show method ------------------------------------------------- - - -# repgrid show method - -# @usage \S4method{show}{repgrid}(object) - -# show method for repgrid class -# org <- list() -# org$show$cut <- 30 -# org$show$showopt <- 1 -# org$show$verbose <- TRUE - -# method depends on the definition of the 'repgrid' object -# hence has to come before this code in COLLATE tag in DESCRIPTION - -# @aliases show,repgrid-method - -# Show method for repgrid -# -# @param object a \code{repgrid} object -# @docType methods -# @usage \S4method{show}{repgrid}(object) -# @include repgrid.r -# - -#' Show method for repgrid -#' -#' @param object A `repgrid` object. -#' @include repgrid.r -#' -setMethod("show", "repgrid", function(object){ - pars <- settings() - trim <- c(pars$show.trim, pars$show.trim) #trim <- c(30,30) - cut <- c(pars$show.cut, pars$show.cut) #cut <- c(20,20) - verbose <- TRUE # what parts to print TRUE prints all information about the grid - showopt <- 1 - id <- c(pars$c.no, pars$e.no) # c(T,T) - hatform <- T - - x <- object - do.bertin <- FALSE - # verbose output displays all grid information available - if (verbose){ - # print meta data - if (pars$show.meta) showMeta(x) - if (pars$show.scale) showScale(x) #print scale info - cat("\nRATINGS:\n") - } - - # make data frame for left and right constructs - con <- constructs(x) - - # make data frame for data - df.ratings <- as.data.frame(x@ratings[ , ,1, drop=FALSE]) # extract scores - colnames(df.ratings) <- elements(x) # name columns - left <- con[ ,1] - right <- con[, 2] - df_out(df.ratings, left, right, just.main="r", hatform=hatform, id=id, - trim=trim, cut=cut, equal=F, showopt=showopt) - cat("\n") - if (do.bertin) - bertin(x) -}) - -# # Show method for repgrid -# # @param repgrid object -# setMethod("show", signature= "repgrid", function(object){ -# x <- object -# showMeta(x) -# showScale(x) #print scale info -# }) - - - -# output version for repertory grids: -# parameters -# -# conside integer to describe side where to print constructs -# 0 no constructs, 1 left side only, 2 both sides, 3 right side only - - - - - - +# trim column of a matrix to equal width +# x: matrix +trim_column_width <- function(x, just = "l") { + lengths <- apply(nchar(x), 2, max) + for (j in seq_len(ncol(x))) { + x[, j] <- format(x[, j], just = just, width = lengths[j]) + } + x +} +# trim_column_width(x, just="r") + + +collapse_matrix <- function(x, collapse = "", sep = " ") { + x <- apply(x, 1, paste, + collapse = collapse, sep = sep + ) # collapse whole matrix + do.call(rbind, as.list(x)) # bind whole matrix together +} + + +# x: matrix +matrix_to_single_char_matrix <- function(x, collapse = "", sep = " ") { + x <- collapse_matrix(x, collapse = collapse, sep = sep) + x <- sapply(x, strsplit, split = "") # split to single chars + names(x) <- NULL # for cleaner output + do.call(rbind, x) # single chars matrix +} + + +# TODO: first line indent wrong +matrix_to_console <- function(x, sep = "") { + # cat(" ") ??? + dummy <- apply(x, 1, function(x) { + cat(c(x, "\n"), collapse = "", sep = sep) + }) +} + +widths_matrix_columns <- function(x) { + apply(x, 2, function(y) max(nchar(y))) +} + + +random_df <- function(nrow = ncol, ncol = nrow, wrow = 6, wcol = 10) { + x <- data.frame(replicate(ncol, sample(1:5, nrow, replace = TRUE))) + rownames(x) <- replicate(nrow, randomSentence(wrow)) + colnames(x) <- replicate(ncol, randomSentence(wcol)) + x +} + + +# @param x a single char matrix +# @param left number of empoty columns added on left side (default 0) +# @param right number of empty columns added at right side (default 0) +# @return matrix +# @keywords internal +add_empty_cols <- function(x, left = 0, right = 0) { + x <- cbind(matrix(" ", nrow = nrow(x), ncol = left), x) + x <- cbind(x, matrix(" ", nrow = nrow(x), ncol = right)) + x +} + + +# Binds two single character matrices of different size horizontally +# +# Two matrices in atomci format are binded horizontally at a specified +# position. The matrices need to be in single char format, i.e. one character per cell +# only. If the dimensions are different, the margins of the matrices are filled up with +# empty cells. +# +# @param um upper matrix (must be single char matrix) +# @param lm lower matrix (must be single char matrix) +# @param anchors two integers specifying at which columns matrices are aligned +# @return matrix +# +# @keywords internal +# @examples \dontrun{ +# um <- matrix("u", ncol=10, nrow=5) +# lm <- matrix("l", ncol=8, nrow=3) +# bind_matrices_horizontally(um, lm, anchors=c(3,1)) +# } +bind_matrices_horizontally <- function(um, lm, anchors = c(1, 1)) { + diff.left <- diff(anchors) # add columns on left side + if (diff.left <= 0) { + um.ncols.empty.left <- 0 + lm.ncols.empty.left <- abs(diff.left) + } else { + um.ncols.empty.left <- abs(diff.left) + lm.ncols.empty.left <- 0 + } + um <- add_empty_cols(um, left = um.ncols.empty.left) + lm <- add_empty_cols(lm, left = lm.ncols.empty.left) + + diff.right <- diff(c(ncol(um), ncol(lm))) # add columns on right side + if (diff.right <= 0) { + um.ncols.empty.right <- 0 + lm.ncols.empty.right <- abs(diff.right) + } else { + um.ncols.empty.right <- abs(diff.right) + lm.ncols.empty.right <- 0 + } + um <- add_empty_cols(um, right = um.ncols.empty.right) + lm <- add_empty_cols(lm, right = lm.ncols.empty.right) + + rbind(um, lm) +} + + + +# break at any point possible +break_output <- function(mat, ncolkeep = 14, keeprows = TRUE) { + availchar <- options()$width # get console size (problematic update) + # print(availchar) + # if (availchar < ncolkeep) # set FALSE to avoid endless recursion + # keeprows <- FALSE + if (ncol(mat) >= availchar) { + mat.tmp <- mat[, 1:(availchar - 1)] + out.tmp <- collapse_matrix(mat.tmp, collapse = "") # collapse rows + matrix_to_console(out.tmp) # print first part to console + cat("\n") # empty line after print out to separate prints + # if (keeprows) { # rownames after each pagebreak? + # mat.residual <- mat[ , c(1:(ncolkeep), availchar:ncol(mat))] + # } else { + mat.residual <- mat[, c(availchar:ncol(mat)), drop = FALSE] + # } + Recall(mat.residual) # recursive output call + } else { + out <- collapse_matrix(mat, collapse = "") # collapse rows + matrix_to_console(out) # print to console + } +} + +trim_string <- function(vec, trim = NA) { + if (!is.na(trim)) { + vec <- substr(vec, 1, trim) + } + vec +} + +make_sep_mat_atomic <- function(sep, nr) { + sep.atomic <- strsplit(sep, "")[[1]] + matrix(sep.atomic, + nrow = nr, + ncol = nchar(sep), byrow = TRUE + ) +} + + + +#' Colorize matrix cell rows using crayon colors +#' +#' Atomic matrices can be wrapped into crayon color codes without +#' destroying the structure or alignment. Used to indicate +#' preferred poles. +#' +#' @param m A matrix. +#' @param colors crayon colors as a string. One of +#' black, red, green, yellow, blue, magenta, cyan, white, +#' silver. +#' @export +#' @keywords internal +#' @examples +#' m <- as.matrix(mtcars) +#' colorize_matrix_rows(m, "red") +#' +colorize_matrix_rows <- function(m, colors = "white", na.val = "white") { + if (!crayon::has_color()) { + return(m) + } + + nr <- nrow(m) + if (length(colors) == 1) { + colors <- rep(colors, nr) + } + if (length(colors) != nr) { + stop("Length of colors must match number of matrix rows", call. = FALSE) + } + + # colorize by row + colors[is.na(colors)] <- na.val + cc <- colors %in% c("black", "red", "green", "yellow", "blue", "magenta", "cyan", "white", "silver") + if (!all(cc)) { + stop("Only crayon colors are allowed", call. = FALSE) + } + + ii <- seq_len(nr) + for (i in ii) { + color_fun <- match.fun(colors[i]) + m[i, ] <- color_fun(m[i, ]) + } + m +} + + +df_out <- function(df, # data frame + left = NA, # rows left + right = NA, # rows right + showopt = 1, # options where to place left and right matrix + # 0=none, 1 = left and right, 2= both left, 3=both right + just.rows = "r", # justification of row names + just.main = "l", # justification of body + max.char.rows = 200, # max no of chars of row names to be printed + sep = " ", # separator symbol between columns + sep2 = " ", # separator between row names and first column + equal = FALSE, # equal width for columns (max column width) + prefix = "", # optional prefix before printed column name + # (e.g. "+---"). characters + keeprows = T, # whether to show rows after each pagebreak + colstart = "l", + margin = 1, # right margin for linebreak + trim = c(NA, NA), # maximum number of character for r/c entry. + cut = c(NA, NA), # maximal number of chars left and right of main matrix + id = c(T, T), # id numbers at beginning/end of each row/column + hatform = FALSE) # column names in hat form +{ + # sanity checks + if (length(trim) == 1) { # if only one parameter given, extend to the other + trim <- recycle(trim, 2) + } + if (length(cut) == 1) { + cut <- recycle(cut, 2) + } + if (length(id) == 1) { + id <- recycle(id, 2) + } + if (!identical(left, NA) & !identical(right, NA)) { + if (length(left) != length(right)) { + stop("left and right must have the same length") + } + if (length(left) != nrow(df) | length(right) != nrow(df)) { + stop("left and/or right must equal number of rows in df") + } + } + + # main matrix mat.m + make_mat_main <- function(df) { + mat.m <- sapply(df, as.character) # convert to character for type security + rownames(mat.m) <- NULL # unnecessary + colnames(mat.m) <- NULL # unnecessary + mat.m <- as.matrix(mat.m) # convert to matrix, + if (nrow(df) == 1) { # re-transpose in single row case + mat.m <- t(mat.m) + } + nchar.column <- widths_matrix_columns(mat.m) # no of chars per column + if (equal) { # equal or dynamic column width + mat.m <- format(mat.m, justify = just.main, width = max(nchar.column)) + } else { + mat.m <- trim_column_width(mat.m, just = just.main) + } + mat.m + } + + # vec vector of strings to be made as column matrix + # idside side at which id is attached (1=start, 2=end) + # trim number of chars to trim strings to + # just justification of text (l, c, r) + make_mat_leftright <- function(vec, id = TRUE, idside = 1, trim = NA, just = "r") { + if (!is.na(trim)) { # trim rownames + left <- substr(vec, 1, trim) + } + if (id) { # add id number to each row + ids <- paste("(", seq_along(vec), ")", sep = "") + if (idside == 1) { # ids at start of string (for right side constructs) + vec <- paste(ids, vec) + } else { + vec <- paste(vec, ids) + } # ids at end of string (for left side constructs) + } + vec <- format(vec, justify = just) # justify rownames + as.matrix(vec) + } + + # make left and right matrices + mat.left <- matrix("", nrow = nrow(df), ncol = 0) # default void matrix to start from + mat.right <- matrix("", nrow = nrow(df), ncol = 0) # default void matrix to start from + + if (!identical(left, NA)) { # trimming occures in all cases if prompted + left <- trim_string(left, trim = trim[1]) + } + if (!identical(right, NA)) { + right <- trim_string(right, trim = trim[1]) + } + leftright <- paste(left, right, sep = " - ") # join left and right strings + + # decision where and how to put left and right vectors + if (showopt == 1) { # #1 left to left, right to right + if (!identical(left, NA)) { + mat.left <- make_mat_leftright(left, id = id[1], idside = 2, just = "r") + } + if (!identical(right, NA)) { + mat.right <- make_mat_leftright(right, id = id[1], idside = 1, just = "l") + } + } else if (showopt == 2) { # #2 left and right on left side + if (!identical(left, NA) & !identical(right, NA)) { + mat.left <- make_mat_leftright(leftright, id = id[1], idside = 2, just = "r") + } else if (identical(left, NA) & !identical(right, NA)) { + mat.left <- make_mat_leftright(right, id = id[1], idside = 2, just = "r") + } else if (!identical(left, NA) & identical(right, NA)) { + mat.left <- make_mat_leftright(left, id = id[1], idside = 2, just = "r") + } + } else if (showopt == 3) { # #3 left and right on right side + if (!identical(left, NA) & !identical(right, NA)) { + mat.right <- make_mat_leftright(leftright, id = id[1], idside = 1, just = "l") + } else if (identical(left, NA) & !identical(right, NA)) { + mat.right <- make_mat_leftright(right, id = id[1], idside = 1, just = "l") + } else if (!identical(left, NA) & identical(right, NA)) { + mat.right <- make_mat_leftright(left, id = id[1], idside = 1, just = "l") + } + } # #0 left and right unused, mat.left and mat.right remain void + + mat.m <- make_mat_main(df) + mat.m.atomic <- matrix_to_single_char_matrix(mat.m, collapse = sep) + + mat.left.atomic <- matrix_to_single_char_matrix(mat.left) + mat.right.atomic <- matrix_to_single_char_matrix(mat.right) + + widths.columns <- widths_matrix_columns(mat.m) # vector column widths + widths.sep1 <- nchar(sep) + widths.sep2 <- nchar(sep2) + + # where to place colnames in matrix upper + columns.start.r <- cumsum(widths.columns + widths.sep1) - widths.sep1 + columns.start.l <- columns.start.r - widths.columns + 1 + columns.start.cl <- columns.start.l + floor((widths.columns + 1) / 2) + columns.start.cr <- columns.start.l + ceiling((widths.columns + 1) / 2) + + # select column start vector + if (colstart == "r") { + columns.start <- columns.start.r + } else if (colstart == "cl") { + columns.start <- columns.start.cl + } else if (colstart == "cr") { + columns.start <- columns.start.cr + } else { + columns.start <- columns.start.l + } + + # maximal rows of mat.u is length of column name plus starting position (plus prefix) + names.columns <- colnames(df) # extract colnames + if (!is.na(trim[2])) { # trim colnames + names.columns <- substr(names.columns, 1, trim[2]) + } + + ### hat = FALSE (upper matrix u in descending form) + if (!hatform) { + if (id[2]) { # add id number to each col + ids <- paste(seq_along(names.columns), "-", sep = " ") + names.columns <- paste(ids, names.columns) + } + + names.columns <- paste(prefix, names.columns, sep = "") # add prefix (default "") + ncol.mat.columns <- max(columns.start + + nchar(names.columns) - 1) # min no columns mat.u + nrow.mat.columns <- length(names.columns) + 1 + mat.u.atomic <- matrix(" ", + nrow = nrow.mat.columns, # empty matrix + ncol = ncol.mat.columns + ) + + # fill matrix upper + names.atomic.list <- strsplit(names.columns, "") + lengths.colnames <- nchar(names.columns) + for (j in seq_along(columns.start)) { # vertical lines ("|") at column starts + mat.u.atomic[(j + 1):nrow(mat.u.atomic), columns.start[j]] <- "|" + mat.u.atomic[j, columns.start[j]:(columns.start[j] + + lengths.colnames[j] - 1)] <- names.atomic.list[[j]] + } + extra.cols.left <- 0 # to suit results of hat=TRUE part + } + + ### hat = TRUE (upper matrix u in hat form) + if (hatform) { + ncol <- length(names.columns) # no of columns + midcol <- ceiling((ncol + 1) / 2) # determine middle column + index.cols.left <- 1:(midcol - 1) # index of left columns + index.cols.right <- midcol:ncol # index of right columns + colnames.left <- names.columns[index.cols.left] # left hat side + colnames.right <- names.columns[index.cols.right] # right hat side + + if (id[2]) { # add id number to each col + ids.left <- seq_along(names.columns)[index.cols.left] + ids.right <- seq_along(names.columns)[index.cols.right] + colnames.left <- paste(colnames.left, ids.left, sep = " - ") + colnames.right <- paste(ids.right, colnames.right, sep = " - ") + } + + # add prefix to both sides (default "") + colnames.left <- paste(colnames.left, strReverse(prefix), sep = "") # left side has revesred prefix + colnames.right <- paste(prefix, colnames.right, sep = "") + colnames.leftright <- c(colnames.left, colnames.right) + lengths.colnames <- nchar(colnames.leftright) + + minpos <- min(columns.start[index.cols.left] - nchar(colnames.left)) # min pos to left + maxpos <- max(columns.start[index.cols.right] + nchar(colnames.right)) # max pos to right + + if (minpos < 0) { + extra.cols.left <- abs(minpos) + } else { + extra.cols.left <- 0 + } + ncol.mat.upper <- extra.cols.left + maxpos # ncol of upper matrix + nrow.mat.upper <- max(c(length(colnames.left), length(colnames.right))) + 1 # nrow of upper matrix + mat.u.atomic <- matrix(" ", + nrow = nrow.mat.upper, # empty upper matrix to get filled + ncol = ncol.mat.upper + ) + + names.atomic.list.left <- strsplit(colnames.left, "") + names.atomic.list.right <- strsplit(colnames.right, "") + names.atomic.list.leftright <- c( + names.atomic.list.left, + names.atomic.list.right + ) + + # fill matrix u and build vertical lines for left and right side + bottom.row <- nrow(mat.u.atomic) + nc <- length(columns.start) + columns.start.offsetted <- extra.cols.left + columns.start + for (j in seq_along(columns.start)) { # vertical lines ("|") at column starts + if (j < ceiling((nc + 1) / 2)) { + mat.u.atomic[ + (bottom.row - j + 1):bottom.row, + columns.start.offsetted[j] + ] <- "|" + mat.u.atomic[ + (bottom.row - j), + (columns.start.offsetted[j] - lengths.colnames[j] + 1): + columns.start.offsetted[j] + ] <- + names.atomic.list.leftright[[j]] + } else { + mat.u.atomic[ + (bottom.row - (nc - j) - 1):bottom.row, + columns.start.offsetted[j] + ] <- "|" + mat.u.atomic[(bottom.row - (nc - j) - 1), columns.start.offsetted[j]: + (columns.start.offsetted[j] + lengths.colnames[j] - 1)] <- + names.atomic.list.leftright[[j]] + } + } # TODO: right side one row too much, maybe erase + } + + # colorize constructs by pole preference + # TODO: Extract pole preferences here + # rows <- nrow(mat.left.atomic) + # colors_ <- sample(c("red", "green", "yellow", "silver", "white"), rows, T) + mat.left.atomic <- colorize_matrix_rows(mat.left.atomic, "white") + mat.right.atomic <- colorize_matrix_rows(mat.right.atomic, "white") + + # browser() + # same part for both types + mat.sep2.atomic <- make_sep_mat_atomic(sep2, nr = nrow(df)) # matrix to separate left and main, or main and right + mat.lm.atomic <- cbind( + mat.left.atomic, mat.sep2.atomic, mat.m.atomic, # lower matrix lm + mat.sep2.atomic, mat.right.atomic + ) + + # join upper and lower matrix + anchor.um <- extra.cols.left + 1 + anchor.lm <- ncol(mat.left.atomic) + ncol(mat.sep2.atomic) + 1 + mat.out.atomic <- bind_matrices_horizontally(mat.u.atomic, mat.lm.atomic, + anchors = c(anchor.um, anchor.lm) + ) + + # cut output at sides if prompted + diff.left <- diff(c(anchor.um, anchor.lm)) + if (diff.left <= 0) { + lm.empty.cols.left <- abs(diff.left) + } else { + lm.empty.cols.left <- 0 + } + start.main.at <- lm.empty.cols.left + ncol(cbind(mat.left.atomic, mat.sep2.atomic)) + end.main.at <- start.main.at + ncol(mat.m.atomic) + + if (!is.na(cut[1]) | !is.na(cut[2])) { + if (is.na(cut[1])) { + end.left <- 1 + } else { + end.left <- trim_val(start.main.at - cut[1], minmax = c(1, 200)) + } + if (is.na(cut[2])) { + end.right <- ncol(mat.out.atomic) + } else { + end.right <- trim_val(end.main.at + cut[2], + minmax = c(1, ncol(mat.out.atomic)) + ) + } + mat.out.atomic <- mat.out.atomic[, end.left:end.right] + } + break_output(mat.out.atomic) + invisible(NULL) +} + +# df <- random_df(10, 25, wcol=4) +# left <- randomSentences(10, 5) +# right <- randomSentences(10, 5) +# df_out(df, left, right, h=T, cut=25, id=T, show=1) + + + +# Show method ------------------------------------------------- + + +# repgrid show method + +# @usage \S4method{show}{repgrid}(object) + +# show method for repgrid class +# org <- list() +# org$show$cut <- 30 +# org$show$showopt <- 1 +# org$show$verbose <- TRUE + +# method depends on the definition of the 'repgrid' object +# hence has to come before this code in COLLATE tag in DESCRIPTION + +# @aliases show,repgrid-method + +# Show method for repgrid +# +# @param object a \code{repgrid} object +# @docType methods +# @usage \S4method{show}{repgrid}(object) +# @include repgrid.r +# + +#' Show method for repgrid +#' +#' @param object A `repgrid` object. +#' @include repgrid.r +#' +setMethod("show", "repgrid", function(object) { + pars <- settings() + trim <- c(pars$show.trim, pars$show.trim) # trim <- c(30,30) + cut <- c(pars$show.cut, pars$show.cut) # cut <- c(20,20) + verbose <- TRUE # what parts to print TRUE prints all information about the grid + showopt <- 1 + id <- c(pars$c.no, pars$e.no) # c(T,T) + hatform <- T + + x <- object + do.bertin <- FALSE + # verbose output displays all grid information available + if (verbose) { + # print meta data + if (pars$show.meta) showMeta(x) + if (pars$show.scale) showScale(x) # print scale info + cat("\nRATINGS:\n") + } + + # make data frame for left and right constructs + con <- constructs(x) + + # make data frame for data + df.ratings <- as.data.frame(x@ratings[, , 1, drop = FALSE]) # extract scores + colnames(df.ratings) <- elements(x) # name columns + left <- con[, 1] + right <- con[, 2] + df_out(df.ratings, left, right, + just.main = "r", hatform = hatform, id = id, + trim = trim, cut = cut, equal = F, showopt = showopt + ) + cat("\n") + if (do.bertin) { + bertin(x) + } +}) + +# # Show method for repgrid +# # @param repgrid object +# setMethod("show", signature= "repgrid", function(object){ +# x <- object +# showMeta(x) +# showScale(x) #print scale info +# }) + + + +# output version for repertory grids: +# parameters +# +# conside integer to describe side where to print constructs +# 0 no constructs, 1 left side only, 2 both sides, 3 right side only diff --git a/R/repgrid-plots.r b/R/repgrid-plots.r index 6914a8ab..e009b21f 100644 --- a/R/repgrid-plots.r +++ b/R/repgrid-plots.r @@ -1,77 +1,79 @@ - -#////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////// #' Calculate coordinates for biplot. #' #' @param x `repgrid` object. -#' @param g Power of the singular value matrix assigned to the left singular +#' @param g Power of the singular value matrix assigned to the left singular #' vectors, i.e. the constructs. -#' @param h Power of the singular value matrix assigned to the right singular +#' @param h Power of the singular value matrix assigned to the right singular #' vectors, i.e. the elements. #' @param col.active Columns (elements) that are no supplementary points, i.e. they are used #' in the SVD to find principal components. default is to use all elements. #' @param col.passive Columns (elements) that are supplementary points, i.e. they are NOT used -#' in the SVD but projected into the component space afterwards. They do not -#' determine the solution. Default is `NA`, i.e. no elements are set +#' in the SVD but projected into the component space afterwards. They do not +#' determine the solution. Default is `NA`, i.e. no elements are set #' supplementary. -#' @param ... Parameters to be passed on to `center()` and `normalize`. +#' @param ... Parameters to be passed on to `center()` and `normalize`. #' @return a `list`. #' @keywords internal #' @export -#' -calcBiplotCoords <- function(x, g=0, h=1-g, - col.active=NA, - col.passive=NA, - ... ){ - # definition of active and passive (supplementary points) - if (!identical(col.active, NA) & !identical(col.passive, NA)) +#' +calcBiplotCoords <- function(x, g = 0, h = 1 - g, + col.active = NA, + col.passive = NA, + ...) { + # definition of active and passive (supplementary points) + if (!identical(col.active, NA) & !identical(col.passive, NA)) { stop("active OR passive columns must be defined") + } ne <- getNoOfElements(x) - if (identical(col.active, NA)){ # if no active points defined - col.active <- seq_len(ne) # the rest is set active + if (identical(col.active, NA)) { # if no active points defined + col.active <- seq_len(ne) # the rest is set active col.active <- setdiff(col.active, col.passive) - } else if (identical(col.passive, NA)){ # if no passive points defined - col.passive <- seq_len(ne) # the is set passive + } else if (identical(col.passive, NA)) { # if no passive points defined + col.passive <- seq_len(ne) # the is set passive col.passive <- setdiff(col.passive, col.active) } - - X <- center(x, ...) # center grid - X <- normalize(X, ...) # normalize grid - - X.active <- X[ , col.active] # X with active columns (elements) only. Used for SVD. - # The other supplementary elements are projected afterwards. - - dec <- svd(X.active) # make SVD for reduced set of active points - U <- dec$u # left singular vector matrix - D <- dec$d # matrix of singular values - V <- dec$v # right singular vector matrix - + + X <- center(x, ...) # center grid + X <- normalize(X, ...) # normalize grid + + X.active <- X[, col.active] # X with active columns (elements) only. Used for SVD. + # The other supplementary elements are projected afterwards. + + dec <- svd(X.active) # make SVD for reduced set of active points + U <- dec$u # left singular vector matrix + D <- dec$d # matrix of singular values + V <- dec$v # right singular vector matrix + # constructs coords - C <- U %*% diag(D^g) # standard form - # C <- X[, col.active] %*% V %*% (D^h)^-1 - # C <- X[, col.active] %*% V %*% (D^(1-g))^-1 - + C <- U %*% diag(D^g) # standard form + # C <- X[, col.active] %*% V %*% (D^h)^-1 + # C <- X[, col.active] %*% V %*% (D^(1-g))^-1 + # element coords # E <- V %*% diag(D^h) # not used as supplementary points need to be calculated - # t(X) %*% U %*% (D^g)^-1 # only works when g + h =1, thus: - E <- t(X) %*% U %*% diag((D^(1-h))^-1) # only dependent on h not g + # t(X) %*% U %*% (D^g)^-1 # only works when g + h =1, thus: + E <- t(X) %*% U %*% diag((D^(1 - h))^-1) # only dependent on h not g - rownames(C) <- constructs(x)[ ,2] # names of direction into which vector points + rownames(C) <- constructs(x)[, 2] # names of direction into which vector points rownames(E) <- elements(x) - - x@calcs$biplot <- list(X=X, element.coords=E, construct.coords=C, - D=D,U=U, V=V, col.passive=col.active, - col.passive=col.passive) + + x@calcs$biplot <- list( + X = X, element.coords = E, construct.coords = C, + D = D, U = U, V = V, col.passive = col.active, + col.passive = col.passive + ) x } -#' Map arbitrary numeric vector to a given range of values. +#' Map arbitrary numeric vector to a given range of values. #' -#' From a given numeric vector `z` the range is determined and -#' the values are linearly mapped onto the interval -#' given by `val.range`. This +#' From a given numeric vector `z` the range is determined and +#' the values are linearly mapped onto the interval +#' given by `val.range`. This #' function can be used in order to map arbitrary vectors to a given #' range of values. #' @@ -80,21 +82,21 @@ calcBiplotCoords <- function(x, g=0, h=1-g, #' @return numeric vector #' @keywords internal #' @export -mapCoordinatesToValue <- function(z, val.range=c(.5, 1)) { - z.range <- c(min(z, na.rm=T), max(z, na.rm=T)) - slope <- diff(val.range) / diff(z.range) - int <- val.range[1] - z.range[1] * slope - vals <- int + slope * z - round(vals, 10) # round at 10th digit to prevent values like 1.00000000001 +mapCoordinatesToValue <- function(z, val.range = c(.5, 1)) { + z.range <- c(min(z, na.rm = T), max(z, na.rm = T)) + slope <- diff(val.range) / diff(z.range) + int <- val.range[1] - z.range[1] * slope + vals <- int + slope * z + round(vals, 10) # round at 10th digit to prevent values like 1.00000000001 } -#' Determine color values according to a given range of values. +#' Determine color values according to a given range of values. #' -#' From a given numeric vector z the range is determined and the values are -#' linearly mapped onto the interval given by `val.range`. Then -#' a color ramp using the colors given by `color` is created and -#' the mapped values are transformed into hex color values. +#' From a given numeric vector z the range is determined and the values are +#' linearly mapped onto the interval given by `val.range`. Then +#' a color ramp using the colors given by `color` is created and +#' the mapped values are transformed into hex color values. #' #' @param z numeric vector. #' @param color vector of length two giving color values `c("white", "black")`. @@ -103,74 +105,73 @@ mapCoordinatesToValue <- function(z, val.range=c(.5, 1)) { #' @keywords internal #' @export #' -mapCoordinatesToColor <- function(z, colors=c("white", "black"), val.range=c(.2,.8)){ +mapCoordinatesToColor <- function(z, colors = c("white", "black"), val.range = c(.2, .8)) { colorRamp <- makeStandardRangeColorRamp(colors) vals <- mapCoordinatesToValue(z, val.range) - colorRamp(unlist(vals)) # unlist in case z comes as a data frame column + colorRamp(unlist(vals)) # unlist in case z comes as a data frame column } -#' Coordinates of a surrounding rectangle in direction of a given vector. +#' Coordinates of a surrounding rectangle in direction of a given vector. #' -#' An arbitrary numeric vector in 2D is to be extended so it will +#' An arbitrary numeric vector in 2D is to be extended so it will #' end on the borders of a surrounding rectangle of a given size. #' Currently the vector is supposed to start in the origin `c(0,0)`. #' -#' @param x numeric vector of x coordinates x coordinates. -#' @param y numeric vector of y coordinates x coordinates. +#' @param x numeric vector of x coordinates x coordinates. +#' @param y numeric vector of y coordinates x coordinates. #' @param xmax maximal x value for surrounding rectangle (default is `1`). #' @param ymax maximal y value for surrounding rectangle (default is `1`). #' @param cx center of rectangle in x direction (not yet supported). #' @param cy center of rectangle in x direction (not yet supported). -#' -#' @return a `dataframe` containing the x and y coordinates for the +#' +#' @return a `dataframe` containing the x and y coordinates for the #' extended vectors. #' @keywords internal #' @export #' @examples \dontrun{ -#' calcCoordsBorders(1:10, 10:1) -#' -#' x <- c(-100:0, 0:100, 100:0, 0:-100)/10 -#' y <- c(0:100, 100:0, -(0:100), -(100:0))/10 -#' xy1 <- calcCoordsBorders(x, y) -#' xy2 <- calcCoordsBorders(x, y, xm=1.2, ym=1.2) -#' plot(xy2[,1], xy2[,2], type="n") -#' segments(xy1[,1],xy1[,2],xy2[,1], xy2[,2]) +#' calcCoordsBorders(1:10, 10:1) +#' +#' x <- c(-100:0, 0:100, 100:0, 0:-100) / 10 +#' y <- c(0:100, 100:0, -(0:100), -(100:0)) / 10 +#' xy1 <- calcCoordsBorders(x, y) +#' xy2 <- calcCoordsBorders(x, y, xm = 1.2, ym = 1.2) +#' plot(xy2[, 1], xy2[, 2], type = "n") +#' segments(xy1[, 1], xy1[, 2], xy2[, 1], xy2[, 2]) #' } #' -calcCoordsBorders <- function(x, y, xmax=1, ymax=1, cx=0, cy=0) -{ - is.lr.part <- abs(x*ymax/xmax) >= abs(y) # which are left and right parts +calcCoordsBorders <- function(x, y, xmax = 1, ymax = 1, cx = 0, cy = 0) { + is.lr.part <- abs(x * ymax / xmax) >= abs(y) # which are left and right parts + + # left and right part + sign.x <- sign(x) # positive or negative value + sign.x[sign.x == 0] <- 1 # zeros in posistive direction + a.lr <- xmax * sign(x) # x is fix on the left and right side + b.lr <- y / x * a.lr - # left and right part - sign.x <- sign(x) # positive or negative value - sign.x[sign.x == 0] <- 1 # zeros in posistive direction - a.lr <- xmax * sign(x) # x is fix on the left and right side - b.lr <- y/x * a.lr - # upper and lower part sign.y <- sign(y) sign.y[sign.y == 0] <- 1 b.ul <- ymax * sign(y) - a.ul <- x/y * b.ul - + a.ul <- x / y * b.ul + a.lr <- unlist(a.lr) b.lr <- unlist(b.lr) a.ul <- unlist(a.ul) b.ul <- unlist(b.ul) - - a.lr[is.nan(a.lr)] <- 0 # in case one of x or y is zero Inf results ans subsequently NaN + + a.lr[is.nan(a.lr)] <- 0 # in case one of x or y is zero Inf results ans subsequently NaN b.lr[is.nan(b.lr)] <- 0 a.ul[is.nan(a.ul)] <- 0 - b.ul[is.nan(b.ul)] <- 0 - + b.ul[is.nan(b.ul)] <- 0 + # join both parts b <- (b.ul * !is.lr.part) + (b.lr * is.lr.part) a <- (a.ul * !is.lr.part) + (a.lr * is.lr.part) a[abs(a) > xmax] <- (xmax * sign(a))[abs(a) > xmax] b[abs(b) > ymax] <- (ymax * sign(b))[abs(b) > ymax] - - data.frame(x=a, y=b) + + data.frame(x = a, y = b) } @@ -181,44 +182,47 @@ calcCoordsBorders <- function(x, y, xmax=1, ymax=1, cx=0, cy=0) # @param xy \code{dataframe} with x and y coords. # @param labels vector of strings. # @param cex vector of cex values (default is \code{.7}). -# @param x.ext scalar giving the horizontal margin +# @param x.ext scalar giving the horizontal margin # of the rectangle in NDC coordinates # (default is \code{.02}). -# @param y.ext scalar giving the vertical margin +# @param y.ext scalar giving the vertical margin # of the rectangle in NDC coordinates # (default is \code{.02}). -# @return \code{dataframe} with coordinates for the lower left and +# @return \code{dataframe} with coordinates for the lower left and # upper right rectangle borders (\code{x0, y0, x1, y1}). # -calcRectanglesCoordsForLabels <- function(xy, labels, cex=.7, - x.ext=.02, y.ext=.02){ - if (length(cex) == 1) +calcRectanglesCoordsForLabels <- function(xy, labels, cex = .7, + x.ext = .02, y.ext = .02) { + if (length(cex) == 1) { cex <- rep(cex, dim(xy)[1]) - + } + heights <- vector() widths <- vector() - - for (i in 1:dim(xy)[1]){ - heights[i] <- strheight(labels[i], cex=cex[i]) # determine necessary height for text - widths[i] <- strwidth(labels[i], cex=cex[i]) # determine necessary width for text + + for (i in 1:dim(xy)[1]) { + heights[i] <- strheight(labels[i], cex = cex[i]) # determine necessary height for text + widths[i] <- strwidth(labels[i], cex = cex[i]) # determine necessary width for text } # make adj adjustements leftSide <- xy[, 1] < 0 - labelsBorders <- data.frame(x0= xy[, 1] - (widths * leftSide), - y0= xy[, 2] - heights/2, - x1= xy[, 1] + (widths * !leftSide), - y1= xy[, 2] + heights/2) + labelsBorders <- data.frame( + x0 = xy[, 1] - (widths * leftSide), + y0 = xy[, 2] - heights / 2, + x1 = xy[, 1] + (widths * !leftSide), + y1 = xy[, 2] + heights / 2 + ) # extend borders for neater look labelsBorders$x0 <- labelsBorders$x0 - x.ext labelsBorders$y0 <- labelsBorders$y0 - y.ext labelsBorders$x1 <- labelsBorders$x1 + x.ext labelsBorders$y1 <- labelsBorders$y1 + y.ext - + labelsBorders } -#' Detect if two rectangles overlap. +#' Detect if two rectangles overlap. #' #' The overlap is assessed in x AND y. #' @@ -230,80 +234,80 @@ calcRectanglesCoordsForLabels <- function(xy, labels, cex=.7, #' @export #' #' @examples \dontrun{ -#' #overlap in x and y -#' a <- c(0,0,2,2) -#' b <- c(1,1,4,3) -#' plot(c(a,b), c(a,b), type="n") -#' rect(a[1], a[2], a[3], a[4]) -#' rect(b[1], b[2], b[3], b[4]) -#' doRectanglesOverlap(a,b) -#' -#' # b contained in a vertically -#' a <- c(5,0,20,20) -#' b <- c(0, 5,15,15) -#' plot(c(a,b), c(a,b), type="n") -#' rect(a[1], a[2], a[3], a[4]) -#' rect(b[1], b[2], b[3], b[4]) -#' doRectanglesOverlap(a,b) -#' -#' # overlap only in y -#' a <- c(0,0,2,2) -#' b <- c(2.1,1,4,3) -#' plot(c(a,b), c(a,b), type="n") -#' rect(a[1], a[2], a[3], a[4]) -#' rect(b[1], b[2], b[3], b[4]) -#' doRectanglesOverlap(a,b) +#' # overlap in x and y +#' a <- c(0, 0, 2, 2) +#' b <- c(1, 1, 4, 3) +#' plot(c(a, b), c(a, b), type = "n") +#' rect(a[1], a[2], a[3], a[4]) +#' rect(b[1], b[2], b[3], b[4]) +#' doRectanglesOverlap(a, b) +#' +#' # b contained in a vertically +#' a <- c(5, 0, 20, 20) +#' b <- c(0, 5, 15, 15) +#' plot(c(a, b), c(a, b), type = "n") +#' rect(a[1], a[2], a[3], a[4]) +#' rect(b[1], b[2], b[3], b[4]) +#' doRectanglesOverlap(a, b) +#' +#' # overlap only in y +#' a <- c(0, 0, 2, 2) +#' b <- c(2.1, 1, 4, 3) +#' plot(c(a, b), c(a, b), type = "n") +#' rect(a[1], a[2], a[3], a[4]) +#' rect(b[1], b[2], b[3], b[4]) +#' doRectanglesOverlap(a, b) #' } #' -doRectanglesOverlap <- function(a, b, margin=0){ - overlap1D <- function(a0, a1, b0, b1){ # overlap if one of four conditions is satisfied - (a0 <= b1 & b1 <= a1) | # b overlaps at bottom - (a0 <= b0 & b0 <= a1) | # b overlaps at top - (a0 >= b0 & a1 <= b1) | # b overlaps at bottom and top - (a0 <= b0 & a1 >= b1) # b contained within a +doRectanglesOverlap <- function(a, b, margin = 0) { + overlap1D <- function(a0, a1, b0, b1) { # overlap if one of four conditions is satisfied + (a0 <= b1 & b1 <= a1) | # b overlaps at bottom + (a0 <= b0 & b0 <= a1) | # b overlaps at top + (a0 >= b0 & a1 <= b1) | # b overlaps at bottom and top + (a0 <= b0 & a1 >= b1) # b contained within a } - overlap.x <- overlap1D(a[1], a[3], b[1], b[3]) # overlap in x ? - overlap.y <- overlap1D(a[2], a[4], b[2], b[4]) # overlap in y ? - as.logical(overlap.x & overlap.y) # overlap in x and y, strip off vector names ? + overlap.x <- overlap1D(a[1], a[3], b[1], b[3]) # overlap in x ? + overlap.y <- overlap1D(a[2], a[4], b[2], b[4]) # overlap in y ? + as.logical(overlap.x & overlap.y) # overlap in x and y, strip off vector names ? } # calculate angle between vector and x-y plane # a vector # n plane normal vector -degreesBetweenVectorAndPlane <- function(a, n){ - rad <- asin( abs(n %*% a) / - (sum(n^2)^.5 * sum(a^2)^.5)) - rad * 180/pi # convert from radians to degrees +degreesBetweenVectorAndPlane <- function(a, n) { + rad <- asin(abs(n %*% a) / + (sum(n^2)^.5 * sum(a^2)^.5)) + rad * 180 / pi # convert from radians to degrees } #' A graphically unsophisticated version of a biplot. #' #' It will draw elements and constructs vectors using similar -#' arguments as [biplot2d()]. It is a version for quick +#' arguments as [biplot2d()]. It is a version for quick #' exploration used during development. -#' +#' #' @param x `repgrid` object. -#' @param dim Dimensions (i.e. principal components) to be used for biplot +#' @param dim Dimensions (i.e. principal components) to be used for biplot #' (default is `c(1,2)`). -#' @param center Numeric. The type of centering to be performed. -#' 0= no centering, 1= row mean centering (construct), +#' @param center Numeric. The type of centering to be performed. +#' 0= no centering, 1= row mean centering (construct), #' 2= column mean centering (elements), 3= double-centering (construct and element means), #' 4= midpoint centering of rows (constructs). #' The default is `1` (row centering). #' @param normalize A numeric value indicating along what direction (rows, columns) #' to normalize by standard deviations. `0 = none, 1= rows, 2 = columns` #' (default is `0`). -#' @param g Power of the singular value matrix assigned to the left singular +#' @param g Power of the singular value matrix assigned to the left singular #' vectors, i.e. the constructs. -#' @param h Power of the singular value matrix assigned to the right singular +#' @param h Power of the singular value matrix assigned to the right singular #' vectors, i.e. the elements. #' @param col.active Columns (elements) that are no supplementary points, i.e. they are used #' in the SVD to find principal components. default is to use all elements. #' @param col.passive Columns (elements) that are supplementary points, i.e. they are NOT used -#' in the SVD but projected into the component space afterwards. They do not -#' determine the solution. Default is `NA`, i.e. no elements are set +#' in the SVD but projected into the component space afterwards. They do not +#' determine the solution. Default is `NA`, i.e. no elements are set #' supplementary. #' @param unity Scale elements and constructs coordinates to unit scale in 2D (maximum of 1) #' so they are printed more neatly (default `TRUE`). @@ -318,7 +322,7 @@ degreesBetweenVectorAndPlane <- function(a, n){ #' @param c.point.col Color of the construct lines (default is `grey(.6)`. #' @param c.label.col Color of the construct labels (default is `grey(.6)`. #' @param c.label.cex Size of the construct labels (default is `.6`. -#' @param ... Parameters to be passed on to `center()` and `normalize`. +#' @param ... Parameters to be passed on to `center()` and `normalize`. #' @return `repgrid` object. #' @export #' @seealso Unsophisticated biplot: [biplotSimple()]; \cr @@ -327,7 +331,7 @@ degreesBetweenVectorAndPlane <- function(a, n){ #' [biplotEsa2d()], #' [biplotSlater2d()];\cr #' Pseudo 3D biplots: -#' [biplotPseudo3d()], +#' [biplotPseudo3d()], #' [biplotEsaPseudo3d()], #' [biplotSlaterPseudo3d()];\cr #' Interactive 3D biplots: @@ -338,85 +342,101 @@ degreesBetweenVectorAndPlane <- function(a, n){ #' [home()]. #' #' @examples \dontrun{ -#' -#' biplotSimple(boeker) -#' biplotSimple(boeker, unity=F) #' -#' biplotSimple(boeker, g=1, h=1) # INGRID biplot -#' biplotSimple(boeker, g=1, h=1, center=4) # ESA biplot +#' biplotSimple(boeker) +#' biplotSimple(boeker, unity = F) +#' +#' biplotSimple(boeker, g = 1, h = 1) # INGRID biplot +#' biplotSimple(boeker, g = 1, h = 1, center = 4) # ESA biplot #' -#' biplotSimple(boeker, zoom=.9) # zooming out -#' biplotSimple(boeker, scale.e=.6) # scale element vectors +#' biplotSimple(boeker, zoom = .9) # zooming out +#' biplotSimple(boeker, scale.e = .6) # scale element vectors #' -#' biplotSimple(boeker, e.point.col="brown") # change colors -#' biplotSimple(boeker, e.point.col="brown", -#' c.label.col="darkblue") +#' biplotSimple(boeker, e.point.col = "brown") # change colors +#' biplotSimple(boeker, +#' e.point.col = "brown", +#' c.label.col = "darkblue" +#' ) #' } #' -biplotSimple <- function(x, dim=1:2, center=1, normalize=0, - g=0, h=1-g, unity=T, - col.active=NA, - col.passive=NA, - scale.e=.9, zoom=1, - e.point.col="black", - e.point.cex=1, - e.label.col="black", - e.label.cex=.7, - c.point.col=grey(.6), - c.label.col=grey(.6), - c.label.cex=.6, - ...){ - par(mar=c(1,1,1,1)) +biplotSimple <- function(x, dim = 1:2, center = 1, normalize = 0, + g = 0, h = 1 - g, unity = T, + col.active = NA, + col.passive = NA, + scale.e = .9, zoom = 1, + e.point.col = "black", + e.point.cex = 1, + e.label.col = "black", + e.label.cex = .7, + c.point.col = grey(.6), + c.label.col = grey(.6), + c.label.cex = .6, + ...) { + par(mar = c(1, 1, 1, 1)) d1 <- dim[1] d2 <- dim[2] - - x <- calcBiplotCoords(x, g=g, h=h, center=center, - normalize=normalize, - col.active=col.active, - col.passive=col.passive, ...) + + x <- calcBiplotCoords(x, + g = g, h = h, center = center, + normalize = normalize, + col.active = col.active, + col.passive = col.passive, ... + ) cnames <- constructs(x) E <- x@calcs$biplot$el C <- x@calcs$biplot$con X <- x@calcs$biplot$X - max.e <- max(abs(E[ ,dim])) - max.c <- max(abs(C[ ,dim])) + max.e <- max(abs(E[, dim])) + max.c <- max(abs(C[, dim])) mv <- max(max.e, max.c) - if (unity){ - max.e <- max(apply(E[ ,dim[1:2]]^2, 1, sum)^.5) # maximal length of element vectors - max.c <- max(apply(C[ ,dim[1:2]]^2, 1, sum)^.5) # maximal length of construct vectors - se <- 1/max.e * scale.e # scale to unity to make E and C same size - sc <- 1/max.c + if (unity) { + max.e <- max(apply(E[, dim[1:2]]^2, 1, sum)^.5) # maximal length of element vectors + max.c <- max(apply(C[, dim[1:2]]^2, 1, sum)^.5) # maximal length of construct vectors + se <- 1 / max.e * scale.e # scale to unity to make E and C same size + sc <- 1 / max.c } else { se <- 1 sc <- 1 } Cu <- C * sc Eu <- E * se - + mv <- max(abs(rbind(Cu, Eu))) Cu <- Cu * zoom Eu <- Eu * zoom - + # make biplot - plot(0, xlim=c(-mv, mv), ylim=c(-mv, mv), type="n", asp=1, - xaxt="n", yaxt="n", xaxs="i", yaxs="i") - abline(v=0, h=0, col="grey") - + plot(0, + xlim = c(-mv, mv), ylim = c(-mv, mv), type = "n", asp = 1, + xaxt = "n", yaxt = "n", xaxs = "i", yaxs = "i" + ) + abline(v = 0, h = 0, col = "grey") + # plot constructs and labels - arrows(0,0, -Cu[ ,d1], -Cu[ ,d2], length=.05, - col=c.point.col, lty=1) # plot left poles - text(-Cu[ ,d1], -Cu[ ,d2], cnames[,1], pos=1, - cex=c.label.cex, col=c.label.col) - arrows(0,0, Cu[ ,d1], Cu[ ,d2], length=.05, - col=c.point.col, lty=3) # plot right poles - text(Cu[ ,d1], Cu[ ,d2], cnames[,2], pos=1, - cex=c.label.cex, col=c.label.col) - + arrows(0, 0, -Cu[, d1], -Cu[, d2], + length = .05, + col = c.point.col, lty = 1 + ) # plot left poles + text(-Cu[, d1], -Cu[, d2], cnames[, 1], + pos = 1, + cex = c.label.cex, col = c.label.col + ) + arrows(0, 0, Cu[, d1], Cu[, d2], + length = .05, + col = c.point.col, lty = 3 + ) # plot right poles + text(Cu[, d1], Cu[, d2], cnames[, 2], + pos = 1, + cex = c.label.cex, col = c.label.col + ) + # plot elements and labels - points(Eu[, dim], pch=15, col=e.point.col, cex=e.point.cex) # plot elements - text(Eu[, dim], labels=rownames(Eu), cex=e.label.cex, - col=e.label.col, pos=2) # label elements + points(Eu[, dim], pch = 15, col = e.point.col, cex = e.point.cex) # plot elements + text(Eu[, dim], + labels = rownames(Eu), cex = e.label.cex, + col = e.label.col, pos = 2 + ) # label elements invisible(x) } @@ -424,7 +444,7 @@ biplotSimple <- function(x, dim=1:2, center=1, normalize=0, # x <- biplotSimple(raeithel, dim=1:2, g=1, h=1, col.act=c(1,2,3,5,10,12)) # ssq.table <- ssq(x) # #ssq.table[ssq.table < 10] <- NA -# res <- xtable(round(ssq.table, 1), digits=1, +# res <- xtable(round(ssq.table, 1), digits=1, # align=c("l", rep("r", ncol(ssq.table))), caption="Percentage of element's SSQ explained") # print(res, table.placement="H", hline.after=c(-1,0,nrow(ssq.table)-1, nrow(ssq.table))) @@ -432,7 +452,7 @@ biplotSimple <- function(x, dim=1:2, center=1, normalize=0, #' Prepare dataframe passed to drawing functions for biplots. #' -#' Data frame contains the variables `type, show, x, y, +#' Data frame contains the variables `type, show, x, y, #' z, labels, color, cex`. #' #' @param x `repgrid` object. @@ -446,7 +466,7 @@ biplotSimple <- function(x, dim=1:2, center=1, normalize=0, #' will have the same color irrespective of their value on the `map.dim` #' dimension. #' @param e.point.cex Size of the element symbols. Two values can be entered that will -#' represents the lower and upper size of a range of cex the values of `map.dim` +#' represents the lower and upper size of a range of cex the values of `map.dim` #' are mapped onto. The default is `c(.4, .8)`. If only one cex value #' is supplied (e.g. `.7`) no mapping occurs and all elements #' will have the same size irrespective of their value on the `map.dim` @@ -458,14 +478,14 @@ biplotSimple <- function(x, dim=1:2, center=1, normalize=0, #' will have the same color irrespective of their value on the `map.dim` #' dimension. #' @param e.label.cex Size of the element labels. Two values can be entered that will -#' represents the lower and upper size of a range of cex the values of `map.dim` +#' represents the lower and upper size of a range of cex the values of `map.dim` #' are mapped onto. The default is `c(.4, .8)`. If only one cex value #' is supplied (e.g. `.7`) no mapping occurs and all element labels #' will have the same size irrespective of their value on the `map.dim` #' dimension. -#' @param e.color.map Value range to determine what range of the color ramp defined in -#' `e.color` will be used for mapping the colors. -#' Default is `c(.4, ,1)`. Usually not important for the user. +#' @param e.color.map Value range to determine what range of the color ramp defined in +#' `e.color` will be used for mapping the colors. +#' Default is `c(.4, ,1)`. Usually not important for the user. #' @param c.point.col Color(s) of the construct symbols. Two values can be entered that will #' create a color ramp. The values of `map.dim` are mapped onto the ramp. #' The default is `c("white", "darkred")`. If only one color color value @@ -473,7 +493,7 @@ biplotSimple <- function(x, dim=1:2, center=1, normalize=0, #' will have the same color irrespective of their value on the `map.dim` #' dimension. #' @param c.point.cex Size of the construct symbols. Two values can be entered that will -#' represents the lower and upper size of a range of cex the values of `map.dim` +#' represents the lower and upper size of a range of cex the values of `map.dim` #' are mapped onto. The default is `c(.4, .8)`. If only one cex value #' is supplied (e.g. `.7`) no mapping occurs and all elements #' will have the same size irrespective of their value on the `map.dim` @@ -485,20 +505,20 @@ biplotSimple <- function(x, dim=1:2, center=1, normalize=0, #' will have the same color irrespective of their value on the `map.dim` #' dimension. #' @param c.label.cex Size of the construct labels. Two values can be entered that will -#' represents the lower and upper size of a range of cex the values of `map.dim` +#' represents the lower and upper size of a range of cex the values of `map.dim` #' are mapped onto. The default is `c(.4, .8)`. If only one cex value #' is supplied (e.g. `.7`) no mapping occurs and all construct labels #' will have the same size irrespective of their value on the `map.dim` #' dimension. -#' @param c.color.map Value range to determine what range of the color ramp defined in +#' @param c.color.map Value range to determine what range of the color ramp defined in #' `c.color` will be used for mapping. Default is `c(.4, ,1)`. -#' Usually not important for the user. +#' Usually not important for the user. #' @param devangle The deviation angle from the x-y plane in degrees. These can only be calculated -#' if a third dimension `map.dim` is specified. Only the constructs -#' vectors that do not depart +#' if a third dimension `map.dim` is specified. Only the constructs +#' vectors that do not depart #' more than the specified degrees from the shown x-y plane will be printed. #' This facilitates the visual interpretation, as only vectors represented in -#' the current plane are shown. Set the value to `91` (default) +#' the current plane are shown. Set the value to `91` (default) #' to show all vectors. #' @param unity Scale elements and constructs coordinates to unit scale in 2D (maximum of 1) #' so they are printed more neatly (default `TRUE`). @@ -506,220 +526,239 @@ biplotSimple <- function(x, dim=1:2, center=1, normalize=0, #' so they are printed more neatly (default `TRUE`). #' @param scale.e Scaling factor for element vectors. Will cause element points to move a bit more #' to the center. This argument is for visual appeal only. -#' @param ... Not evaluated. +#' @param ... Not evaluated. #' -#' @return `dataframe` containing the variables `type, show, x, y, +#' @return `dataframe` containing the variables `type, show, x, y, #' z, labels, color, cex`. Usually not of interest to the user. #' @note TODO: How to omit `map.dim`? #' @keywords internal #' @export #' -prepareBiplotData <- function(x, dim=c(1,2), map.dim=3, - #e.color=c("white", "black"), - #c.color=c("white", "darkred"), - e.label.cex=.8, - c.label.cex=.6, - e.label.col="black", - c.label.col=grey(.8), - e.point.cex=.7, - c.point.cex=.8, - e.point.col="black", - c.point.col="darkred", - #e.cex.map=c(.6, .8), - #c.cex.map=c(.6, .8), - e.color.map=c(.4, 1), - c.color.map=c(.4, 1), - c.points.devangle=90, - c.labels.devangle=90, - c.points.show=TRUE, - c.labels.show=TRUE, - e.points.show=TRUE, - e.labels.show=TRUE, - unity=TRUE, - unity3d=FALSE, - scale.e=.9, - ...) -{ +prepareBiplotData <- function(x, dim = c(1, 2), map.dim = 3, + # e.color=c("white", "black"), + # c.color=c("white", "darkred"), + e.label.cex = .8, + c.label.cex = .6, + e.label.col = "black", + c.label.col = grey(.8), + e.point.cex = .7, + c.point.cex = .8, + e.point.col = "black", + c.point.col = "darkred", + # e.cex.map=c(.6, .8), + # c.cex.map=c(.6, .8), + e.color.map = c(.4, 1), + c.color.map = c(.4, 1), + c.points.devangle = 90, + c.labels.devangle = 90, + c.points.show = TRUE, + c.labels.show = TRUE, + e.points.show = TRUE, + e.labels.show = TRUE, + unity = TRUE, + unity3d = FALSE, + scale.e = .9, + ...) { dim <- c(dim, map.dim) # make vector of length two if only one color/cex is specified - #if (length(e.color) == 1) # element color - # e.color <- rep(e.color, 2) - #if (length(c.color) == 1) # construct color + # if (length(e.color) == 1) # element color + # e.color <- rep(e.color, 2) + # if (length(c.color) == 1) # construct color # c.color <- rep(c.color, 2) - #if (length(e.cex.map) == 1) # element cex for pseudo 3d dimension + # if (length(e.cex.map) == 1) # element cex for pseudo 3d dimension # e.cex.map <- rep(e.cex.map, 2) - #if (length(c.cex.map) == 1) # construct cex for pseudo 3d dimension + # if (length(c.cex.map) == 1) # construct cex for pseudo 3d dimension # c.cex.map <- rep(c.cex.map, 2) - - if (length(e.label.col) == 1) # label color(s) for elements + + if (length(e.label.col) == 1) { # label color(s) for elements e.label.col <- rep(e.label.col, 2) - if (length(c.label.col) == 1) # label color(s) for constructs - c.label.col <- rep(c.label.col, 2) - if (length(e.point.col) == 1) # point color(s) for elements + } + if (length(c.label.col) == 1) { # label color(s) for constructs + c.label.col <- rep(c.label.col, 2) + } + if (length(e.point.col) == 1) { # point color(s) for elements e.point.col <- rep(e.point.col, 2) - if (length(c.point.col) == 1) # point color(s) for constructs + } + if (length(c.point.col) == 1) { # point color(s) for constructs c.point.col <- rep(c.point.col, 2) - - if (length(e.label.cex) == 1) # label cex(s) for elements + } + + if (length(e.label.cex) == 1) { # label cex(s) for elements e.label.cex <- rep(e.label.cex, 2) - if (length(c.label.cex) == 1) # label cex(s) for constructs - c.label.cex <- rep(c.label.cex, 2) - if (length(e.point.cex) == 1) # point cex(s) for elements + } + if (length(c.label.cex) == 1) { # label cex(s) for constructs + c.label.cex <- rep(c.label.cex, 2) + } + if (length(e.point.cex) == 1) { # point cex(s) for elements e.point.cex <- rep(e.point.cex, 2) - if (length(c.point.cex) == 1) # point cex(s) for constructs + } + if (length(c.point.cex) == 1) { # point cex(s) for constructs c.point.cex <- rep(c.point.cex, 2) - - if (length(e.color.map) == 1) # element color for pseudo 3d dimension - e.color.map <- rep(e.color.map, 2) - if (length(c.color.map) == 1) # construct color for pseudo 3d dimension - c.color.map <- rep(c.color.map, 2) - + } + + if (length(e.color.map) == 1) { # element color for pseudo 3d dimension + e.color.map <- rep(e.color.map, 2) + } + if (length(c.color.map) == 1) { # construct color for pseudo 3d dimension + c.color.map <- rep(c.color.map, 2) + } + # construct data frame containing all information needed for different plotting functions # (e.g. rgl and biplot functions) labels.e <- elements(x) - labels.cl <- constructs(x)[,1] - labels.cr <- constructs(x)[,2] - labels.all <- c(labels.e, labels.cr, labels.cl) # join all labels - type <- factor(c(rep("e", getNoOfElements(x)), # make factor specifying if row is element or construct - rep(c("cl", "cr"), each=getNoOfConstructs(x)))) - df <- data.frame(type=type, label=labels.all, stringsAsFactors=FALSE) - df$cex <- .7 # default cex - df$showpoint <- T # default value for show point - df$showlabel <- T # default value for show label - df$color <- grey(0) # default color - df$label.col <- "darkgreen" # default label color - df$point.col <- "purple" # default point color - df$label.cex <- .7 # default label size - df$point.cex <- .7 # default point size - + labels.cl <- constructs(x)[, 1] + labels.cr <- constructs(x)[, 2] + labels.all <- c(labels.e, labels.cr, labels.cl) # join all labels + type <- factor(c( + rep("e", getNoOfElements(x)), # make factor specifying if row is element or construct + rep(c("cl", "cr"), each = getNoOfConstructs(x)) + )) + df <- data.frame(type = type, label = labels.all, stringsAsFactors = FALSE) + df$cex <- .7 # default cex + df$showpoint <- T # default value for show point + df$showlabel <- T # default value for show label + df$color <- grey(0) # default color + df$label.col <- "darkgreen" # default label color + df$point.col <- "purple" # default point color + df$label.cex <- .7 # default label size + df$point.cex <- .7 # default point size + # calculate and add coordinates - #x <- calcBiplotCoords(x, ...) - + # x <- calcBiplotCoords(x, ...) + E <- x@calcs$biplot$el C <- x@calcs$biplot$con X <- x@calcs$biplot$X # scale to unity to make E and C same size. # Two types of unity, for 2D and 3D - - if (unity){ - max.e <- max(apply(E[ ,dim[1:2]]^2, 1, sum)^.5) # maximal length of element vectors - max.c <- max(apply(C[ ,dim[1:2]]^2, 1, sum)^.5) # maximal length of construct vectors - se <- 1/max.e * scale.e # scale to unity to make E and C same size - sc <- 1/max.c - } - if (unity3d){ - #max.e <- max(abs(E[ ,dim[1:3]]), na.rm=T) - #max.c <- max(abs(C[ ,dim[1:3]]), na.rm=T) - max.e <- max(apply(E[ ,dim[1:3]]^2, 1, sum)^.5) # maximal length of element vectors - max.c <- max(apply(C[ ,dim[1:3]]^2, 1, sum)^.5) # maximal length of construct vectors - se <- 1/max.e * scale.e # scale to unity to make E and C same size - sc <- 1/max.c - } - if (!unity & !unity3d){ + + if (unity) { + max.e <- max(apply(E[, dim[1:2]]^2, 1, sum)^.5) # maximal length of element vectors + max.c <- max(apply(C[, dim[1:2]]^2, 1, sum)^.5) # maximal length of construct vectors + se <- 1 / max.e * scale.e # scale to unity to make E and C same size + sc <- 1 / max.c + } + if (unity3d) { + # max.e <- max(abs(E[ ,dim[1:3]]), na.rm=T) + # max.c <- max(abs(C[ ,dim[1:3]]), na.rm=T) + max.e <- max(apply(E[, dim[1:3]]^2, 1, sum)^.5) # maximal length of element vectors + max.c <- max(apply(C[, dim[1:3]]^2, 1, sum)^.5) # maximal length of construct vectors + se <- 1 / max.e * scale.e # scale to unity to make E and C same size + sc <- 1 / max.c + } + if (!unity & !unity3d) { se <- 1 sc <- 1 } Cu <- C * sc Eu <- E * se - - coords <- rbind(Eu[, dim], Cu[ ,dim], -Cu[ ,dim]) + + coords <- rbind(Eu[, dim], Cu[, dim], -Cu[, dim]) colnames(coords) <- c("x", "y", "z") - rownames(coords) <- NULL # otherwise warning in cbind occurs - df <- cbind(df, coords) #, check.rows=F) - if (is.na(dim[3])) # if no 3rd dimension in specified, all values are set to zero i.e. neutral + rownames(coords) <- NULL # otherwise warning in cbind occurs + df <- cbind(df, coords) # , check.rows=F) + if (is.na(dim[3])) { # if no 3rd dimension in specified, all values are set to zero i.e. neutral df$z <- 0 - + } + # plot coords for all points - z <- subset(df, type=="e", sel=z) # z scores for elements - #cex.e <- mapCoordinatesToValue(z, e.cex.map) + z <- subset(df, type == "e", sel = z) # z scores for elements + # cex.e <- mapCoordinatesToValue(z, e.cex.map) cex.label.e <- mapCoordinatesToValue(z, e.label.cex) cex.point.e <- mapCoordinatesToValue(z, e.point.cex) - #color.e <- mapCoordinatesToColor(z, color=e.color, val.range=e.color.map) - color.label.e <- mapCoordinatesToColor(z, colors=e.label.col, val.range=e.color.map) - color.point.e <- mapCoordinatesToColor(z, colors=e.point.col, val.range=e.color.map) - - z <- subset(df, type=="cl", sel=z) - #cex.cl <- mapCoordinatesToValue(z, c.cex.map) + # color.e <- mapCoordinatesToColor(z, color=e.color, val.range=e.color.map) + color.label.e <- mapCoordinatesToColor(z, colors = e.label.col, val.range = e.color.map) + color.point.e <- mapCoordinatesToColor(z, colors = e.point.col, val.range = e.color.map) + + z <- subset(df, type == "cl", sel = z) + # cex.cl <- mapCoordinatesToValue(z, c.cex.map) cex.label.cl <- mapCoordinatesToValue(z, c.label.cex) - cex.point.cl <- mapCoordinatesToValue(z, c.point.cex) - #color.cl <- mapCoordinatesToColor(z, color=c.color, val.range=c.color.map) - color.label.cl <- mapCoordinatesToColor(z, colors=c.label.col, val.range=c.color.map) - color.point.cl <- mapCoordinatesToColor(z, colors=c.point.col, val.range=c.color.map) + cex.point.cl <- mapCoordinatesToValue(z, c.point.cex) + # color.cl <- mapCoordinatesToColor(z, color=c.color, val.range=c.color.map) + color.label.cl <- mapCoordinatesToColor(z, colors = c.label.col, val.range = c.color.map) + color.point.cl <- mapCoordinatesToColor(z, colors = c.point.col, val.range = c.color.map) - z <- subset(df, type=="cr", sel=z) - #cex.cr <- mapCoordinatesToValue(z, c.cex.map) + z <- subset(df, type == "cr", sel = z) + # cex.cr <- mapCoordinatesToValue(z, c.cex.map) cex.label.cr <- mapCoordinatesToValue(z, c.label.cex) cex.point.cr <- mapCoordinatesToValue(z, c.point.cex) - #color.cr <- mapCoordinatesToColor(z, color=c.color, val.range=c.color.map) - color.label.cr <- mapCoordinatesToColor(z, colors=c.label.col, val.range=c.color.map) - color.point.cr <- mapCoordinatesToColor(z, colors=c.point.col, val.range=c.color.map) - - #df$cex <- unlist(rbind(cex.e, cex.cl, cex.cr)) - #df$color <- c(color.e, color.cl, color.cr) - df$label.col <- c(color.label.e, color.label.cl, color.label.cr) - df$point.col <- c(color.point.e, color.point.cl, color.point.cr) - df$label.cex <- unlist(c(cex.label.e, cex.label.cl, cex.label.cr)) - df$point.cex <- unlist(c(cex.point.e, cex.point.cl, cex.point.cr)) - df$devangle <- apply(df, 1, function(x) { - a <- as.numeric( c(x["x"], x["y"], x["z"]) ) - n <- c(0,0,1) # normal vector for x-y plane - degreesBetweenVectorAndPlane(a=a, n=n) + # color.cr <- mapCoordinatesToColor(z, color=c.color, val.range=c.color.map) + color.label.cr <- mapCoordinatesToColor(z, colors = c.label.col, val.range = c.color.map) + color.point.cr <- mapCoordinatesToColor(z, colors = c.point.col, val.range = c.color.map) + + # df$cex <- unlist(rbind(cex.e, cex.cl, cex.cr)) + # df$color <- c(color.e, color.cl, color.cr) + df$label.col <- c(color.label.e, color.label.cl, color.label.cr) + df$point.col <- c(color.point.e, color.point.cl, color.point.cr) + df$label.cex <- unlist(c(cex.label.e, cex.label.cl, cex.label.cr)) + df$point.cex <- unlist(c(cex.point.e, cex.point.cl, cex.point.cr)) + df$devangle <- apply(df, 1, function(x) { + a <- as.numeric(c(x["x"], x["y"], x["z"])) + n <- c(0, 0, 1) # normal vector for x-y plane + degreesBetweenVectorAndPlane(a = a, n = n) }) - + # calculate absolute deviation angle from shown plane. If it is bigger than given values # the constructs will not be shown on the side and/or the construct points will - # not be printed. If values >=90 all strokes and points are shown. + # not be printed. If values >=90 all strokes and points are shown. cs <- subset(df, type %in% c("cl", "cr")) - draw <- abs(cs$devangle) <= c.labels.devangle # which angles are smaller or equal than the maximal allowed ones? - cs$showlabel <- cs$showlabel & draw # show only labels that are requested and within allowed angle range - draw <- abs(cs$devangle) <= c.points.devangle # which angles are smaller or equal than the maximal allowed ones? - cs$showpoint <- cs$showpoint & draw # show only labels that are requested and within allowed angle range - df[df$type %in% c("cl", "cr"), ] <- cs # show only labels that are requested and within allowed angle range + draw <- abs(cs$devangle) <= c.labels.devangle # which angles are smaller or equal than the maximal allowed ones? + cs$showlabel <- cs$showlabel & draw # show only labels that are requested and within allowed angle range + draw <- abs(cs$devangle) <= c.points.devangle # which angles are smaller or equal than the maximal allowed ones? + cs$showpoint <- cs$showpoint & draw # show only labels that are requested and within allowed angle range + df[df$type %in% c("cl", "cr"), ] <- cs # show only labels that are requested and within allowed angle range # elements # # select which element labels to show # numerical values for element selection are converted to logical seq.e <- seq_len(getNoOfElements(x)) - if (! (identical(e.labels.show, T) | identical(e.labels.show, F) | all(is.numeric(e.labels.show))) ) + if (!(identical(e.labels.show, T) | identical(e.labels.show, F) | all(is.numeric(e.labels.show)))) { stop("'e.labels.show' must either be a logical value or a numeric vector") - if (all(is.numeric(e.labels.show))) - e.labels.show <- seq.e %in% seq.e[e.labels.show] - df[df$type == "e", "showlabel"] <- e.labels.show # replace showlabel column for elements + } + if (all(is.numeric(e.labels.show))) { + e.labels.show <- seq.e %in% seq.e[e.labels.show] + } + df[df$type == "e", "showlabel"] <- e.labels.show # replace showlabel column for elements # select which element points to show # numerical values for element selection are converted to logical - if (! (identical(e.points.show, T) | identical(e.points.show, F) | all(is.numeric(e.points.show))) ) + if (!(identical(e.points.show, T) | identical(e.points.show, F) | all(is.numeric(e.points.show)))) { stop("'e.points.show' must either be a logical value or a numeric vector") - if (all(is.numeric(e.points.show))) - e.points.show <- seq.e %in% seq.e[e.points.show] - df[df$type == "e", "showpoint"] <- e.points.show # replace showpoint column for elements + } + if (all(is.numeric(e.points.show))) { + e.points.show <- seq.e %in% seq.e[e.points.show] + } + df[df$type == "e", "showpoint"] <- e.points.show # replace showpoint column for elements # constructs # TODO: mechanism fill fail for single / double mode grids # select which construct labels to show (independently from devangle) # numerical values for construct selection are converted to logical - seq.c <- seq_len(getNoOfConstructs(x)) # TODO for single mode grids - if (! (identical(c.labels.show, T) | identical(c.labels.show, F) | all(is.numeric(c.labels.show))) ) - stop("'c.labels.show' must either be a logical value or a numeric vector") - if (all(is.numeric(c.labels.show))){ - doubleadd <- c.labels.show + sign(c.labels.show[1]) * getNoOfConstructs(x) # if double mode - c.labels.show <- seq.c %in% seq.c[c(c.labels.show, doubleadd)] + seq.c <- seq_len(getNoOfConstructs(x)) # TODO for single mode grids + if (!(identical(c.labels.show, T) | identical(c.labels.show, F) | all(is.numeric(c.labels.show)))) { + stop("'c.labels.show' must either be a logical value or a numeric vector") + } + if (all(is.numeric(c.labels.show))) { + doubleadd <- c.labels.show + sign(c.labels.show[1]) * getNoOfConstructs(x) # if double mode + c.labels.show <- seq.c %in% seq.c[c(c.labels.show, doubleadd)] } - show.tmp <- df[df$type %in% c("cl", "cr"), "showlabel"] - df[df$type %in% c("cl", "cr"), "showlabel"] <- c.labels.show & show.tmp # replace showlabel column for elements + show.tmp <- df[df$type %in% c("cl", "cr"), "showlabel"] + df[df$type %in% c("cl", "cr"), "showlabel"] <- c.labels.show & show.tmp # replace showlabel column for elements # select which construct points to show (independently from devangle) # numerical values for construct selection are converted to logical - if (! (identical(c.points.show, T) | identical(c.points.show, F) | all(is.numeric(c.points.show))) ) + if (!(identical(c.points.show, T) | identical(c.points.show, F) | all(is.numeric(c.points.show)))) { stop("'c.points.show' must either be a logical value or a numeric vector") - if (all(is.numeric(c.points.show))) - c.points.show <- seq.c %in% seq.c[c.points.show] + } + if (all(is.numeric(c.points.show))) { + c.points.show <- seq.c %in% seq.c[c.points.show] + } points.tmp <- df[df$type %in% c("cl", "cr"), "showpoint"] - df[df$type %in% c("cl", "cr"), "showpoint"] <- c.points.show & points.tmp # replace showpoint column for elements - - #list(rg=x, df=df) + df[df$type %in% c("cl", "cr"), "showpoint"] <- c.points.show & points.tmp # replace showpoint column for elements + + # list(rg=x, df=df) x@calcs$biplot$e.unity <- Eu x@calcs$biplot$c.unity <- Cu x@plotdata <- df @@ -727,220 +766,228 @@ prepareBiplotData <- function(x, dim=c(1,2), map.dim=3, } -#' biplotDraw is the workhorse doing the drawing of a 2D biplot. +#' biplotDraw is the workhorse doing the drawing of a 2D biplot. #' -#' When the number of elements and constructs differs to a large extent, the -#' absolute values of the coordinates for either constructs or elements +#' When the number of elements and constructs differs to a large extent, the +#' absolute values of the coordinates for either constructs or elements #' will be much smaller or greater. This is an inherent property of the biplot. -#' In the case it is not necessary to be able to read off the original +#' In the case it is not necessary to be able to read off the original #' data entries from the plot, the axes for elements and constructs -#' can be scaled separately. The proportional projection values will -#' stay unaffected. the absolute will change though. For grid interpretation +#' can be scaled separately. The proportional projection values will +#' stay unaffected. the absolute will change though. For grid interpretation #' the absolute values are usually oh no importance. Thus, there is an optional #' argument `normalize` which is `FALSE` as a default which -#' rescales the axes so the longest construct and element vector will be +#' rescales the axes so the longest construct and element vector will be #' set to the length of `1`. -#' +#' #' @param x `repgrid` object. -#' @param inner.positioning Logical. Whether to calculate positions to minimize overplotting of +#' @param inner.positioning Logical. Whether to calculate positions to minimize overplotting of #' elements and construct labels (default is`TRUE`). Note that #' the positioning may slow down the plotting. -#' @param outer.positioning Logical. Whether to calculate positions to minimize overplotting of +#' @param outer.positioning Logical. Whether to calculate positions to minimize overplotting of #' of construct labels on the outer borders (default is`TRUE`). Note that #' the positioning may slow down the plotting. #' @param c.labels.inside Logical. Whether to print construct labels next to the points. #' Can be useful during inspection of the plot (default `FALSE`). -#' @param flipaxes Logical vector of length two. Whether x and y axes are reversed +#' @param flipaxes Logical vector of length two. Whether x and y axes are reversed #' (default is `c(F,F)`). -#' @param strokes.x Length of outer strokes in x direction in NDC. +#' @param strokes.x Length of outer strokes in x direction in NDC. #' @param strokes.y Length of outer strokes in y direction in NDC. #' @param offsetting Do offsetting? (TODO) #' @param offset.labels Offsetting parameter for labels (TODO). #' @param offset.e offsetting parameter for elements (TODO). -#' @param axis.ext Axis extension factor (default is `.1`). A bigger value will +#' @param axis.ext Axis extension factor (default is `.1`). A bigger value will #' zoom out the plot. -#' @param mai Margins available for plotting the labels in inch +#' @param mai Margins available for plotting the labels in inch #' (default is `c(.2, 1.5, .2, 1.5)`). #' @param rect.margins Vector of length two (default is `c(.07, .07)`). Two values -#' specifying the additional horizontal and vertical margin around each -#' label. +#' specifying the additional horizontal and vertical margin around each +#' label. #' @param srt Angle to rotate construct label text. Only used in case `offsetting=FALSE`. #' @param cex.pos Cex parameter used during positioning of labels if prompted. Does #' usually not have to be changed by user. -#' @param xpd Logical (default is `TRUE`). Whether to extend text labels -#' over figure region. Usually not needed by the user. +#' @param xpd Logical (default is `TRUE`). Whether to extend text labels +#' over figure region. Usually not needed by the user. #' @param c.lines Logical. Whether construct lines from the center of the biplot #' to the surrounding box are drawn (default is `FALSE`). -#' @param col.c.lines The color of the construct lines from the center to the borders +#' @param col.c.lines The color of the construct lines from the center to the borders #' of the plot (default is `gray(.9)`). #' @param zoom Scaling factor for all vectors. Can be used to zoom #' the plot in and out (default `1`). #' @param ... Not evaluated. -#' @return Invisible return of dataframe used during construction of plot +#' @return Invisible return of dataframe used during construction of plot #' (useful for developers). #' @export #' @keywords internal #' -biplotDraw <- function(x, - inner.positioning=TRUE, - outer.positioning=TRUE, - c.labels.inside=F, - flipaxes=c(F,F), - strokes.x=.1, strokes.y=.1, - offsetting=TRUE, offset.labels=.0, offset.e= 1, - axis.ext=.1, mai=c(.2, 1.5, .2, 1.5), - rect.margins=c(.01, .01), - srt=45, - cex.pos=.7, - xpd=TRUE, - c.lines=TRUE, ### new - col.c.lines=grey(.9), - zoom=1, - ...) -{ - y <- showpoint <- showlabel <- type <- NULL # to prevent 'R CMD check' from noting a missing binding - # as the variables are provided in object x as default - - x <- x@plotdata # df = data frame containing the information for printing - - max.all <- max(abs(x$x), abs(x$y)) - axis.ext <- 1 + axis.ext +biplotDraw <- function(x, + inner.positioning = TRUE, + outer.positioning = TRUE, + c.labels.inside = F, + flipaxes = c(F, F), + strokes.x = .1, strokes.y = .1, + offsetting = TRUE, offset.labels = .0, offset.e = 1, + axis.ext = .1, mai = c(.2, 1.5, .2, 1.5), + rect.margins = c(.01, .01), + srt = 45, + cex.pos = .7, + xpd = TRUE, + c.lines = TRUE, ### new + col.c.lines = grey(.9), + zoom = 1, + ...) { + y <- showpoint <- showlabel <- type <- NULL # to prevent 'R CMD check' from noting a missing binding + # as the variables are provided in object x as default + + x <- x@plotdata # df = data frame containing the information for printing + + max.all <- max(abs(x$x), abs(x$y)) + axis.ext <- 1 + axis.ext max.ext <- max.all * axis.ext - - x$x <- x$x * zoom # zoom data - x$y <- x$y * zoom # zoom data - - # if (! draw.c) + + x$x <- x$x * zoom # zoom data + x$y <- x$y * zoom # zoom data + + # if (! draw.c) # x$labels[x$type %in% c("cl", "cr")] <- " " - - labels.constructs <- x$labels[x$type %in% c("cl", "cr")] - labels.all <- x$labels - - if (flipaxes[1]) - x$x <- x$x * -1 - if (flipaxes[2]) - x$y <- x$y * -1 - - # build plot - old.par <- par(no.readonly = TRUE) # save parameters - #on.exit(par(old.par)) # reset old par when done - - par(mai=mai) - plot.new() - plot.window(xlim = c(-max.ext, max.ext), - ylim = c(-max.ext, max.ext), - xaxs="i", yaxs="i", asp=1) - - # add center lines and outer rectangle - segments(-max.ext, 0, max.ext, 0, col="lightgrey") - segments(0, -max.ext, 0, max.ext, col="lightgrey") - rect(-max.ext, -max.ext, max.ext, max.ext) - - # make standard concentration ellipse # TODO, scaling of ellipse - #sing <- diag(esa$sing)[dim] / sum(diag(esa$sing)) - #ellipse(sing[1], sing[2], col="lightgrey") - - + + labels.constructs <- x$labels[x$type %in% c("cl", "cr")] + labels.all <- x$labels + + if (flipaxes[1]) { + x$x <- x$x * -1 + } + if (flipaxes[2]) { + x$y <- x$y * -1 + } + + # build plot + old.par <- par(no.readonly = TRUE) # save parameters + # on.exit(par(old.par)) # reset old par when done + + par(mai = mai) + plot.new() + plot.window( + xlim = c(-max.ext, max.ext), + ylim = c(-max.ext, max.ext), + xaxs = "i", yaxs = "i", asp = 1 + ) + + # add center lines and outer rectangle + segments(-max.ext, 0, max.ext, 0, col = "lightgrey") + segments(0, -max.ext, 0, max.ext, col = "lightgrey") + rect(-max.ext, -max.ext, max.ext, max.ext) + + # make standard concentration ellipse # TODO, scaling of ellipse + # sing <- diag(esa$sing)[dim] / sum(diag(esa$sing)) + # ellipse(sing[1], sing[2], col="lightgrey") + + # initial coords for labels for strokes - str.3 <- calcCoordsBorders(x["x"], x["y"], - xmax=max.ext * (1 + strokes.x + offset.labels), # + rect.margins[1]/2), - ymax=max.ext * (1 + strokes.y + offset.labels))# + rect.margins[2]/2)) - colnames(str.3) <- c("str.3.x", "str.3.y") + str.3 <- calcCoordsBorders(x["x"], x["y"], + xmax = max.ext * (1 + strokes.x + offset.labels), # + rect.margins[1]/2), + ymax = max.ext * (1 + strokes.y + offset.labels) + ) # + rect.margins[2]/2)) + colnames(str.3) <- c("str.3.x", "str.3.y") x <- cbind(x, str.3) - - #segments(0,0,x$str.3.x, x$str.3.y) # debug + + # segments(0,0,x$str.3.x, x$str.3.y) # debug # calc coordinates for surrounding rectangles (elements and constructs) - lb <- calcRectanglesCoordsForLabels(x[, c("str.3.x", "str.3.y")], x$label, - cex=x$label.cex, x.ext=rect.margins[1], y.ext=rect.margins[2]) + lb <- calcRectanglesCoordsForLabels(x[, c("str.3.x", "str.3.y")], x$label, + cex = x$label.cex, x.ext = rect.margins[1], y.ext = rect.margins[2] + ) colnames(lb) <- c("str.3.x0", "str.3.y0", "str.3.x1", "str.3.y1") x <- cbind(x, lb) - #segments(x$str.3.x0, x$str.3.y0, x$str.3.x1, x$str.3.y1) # debug - - + # segments(x$str.3.x0, x$str.3.y0, x$str.3.x1, x$str.3.y1) # debug + + # offset labels in y direction if too close together # for labels on the left and on the right separately - x$angle <- atan2(x$y, x$x) # caveat: first y, then y argument! - x <- x[order(x$angle), ] # sort by angles + x$angle <- atan2(x$y, x$x) # caveat: first y, then y argument! + x <- x[order(x$angle), ] # sort by angles # assign quandrants for offsetting - x$quadrant[x$angle >= 0 & x$angle < pi/2] <- "ur" # - x$quadrant[x$angle >= pi/2 & x$angle <= pi] <- "ul" # - x$quadrant[x$angle < 0 & x$angle >= -pi/2] <- "lr" # - x$quadrant[x$angle < -pi/2 & x$angle >= -pi] <- "ll" # - - + x$quadrant[x$angle >= 0 & x$angle < pi / 2] <- "ur" # + x$quadrant[x$angle >= pi / 2 & x$angle <= pi] <- "ul" # + x$quadrant[x$angle < 0 & x$angle >= -pi / 2] <- "lr" # + x$quadrant[x$angle < -pi / 2 & x$angle >= -pi] <- "ll" # + + # calc necessary offset (only correct in case there is overlap!) - necessaryOffset <- function(a, b, direction=1, margin=.05){ - if (direction >= 0){ # offset upwards - offset <- a[4] - b[2] # is always positive >= 0 - if (offset < 0) # if smaller than zero there should be no overlap anyway + necessaryOffset <- function(a, b, direction = 1, margin = .05) { + if (direction >= 0) { # offset upwards + offset <- a[4] - b[2] # is always positive >= 0 + if (offset < 0) { # if smaller than zero there should be no overlap anyway offset <- 0 - } else { # offset downwards - offset <- a[2] - b[4] # should always be <= 0 - if (offset > 0) # if bigger than zero there is no overlap + } + } else { # offset downwards + offset <- a[2] - b[4] # should always be <= 0 + if (offset > 0) { # if bigger than zero there is no overlap offset <- 0 + } } as.numeric(offset + margin * sign(direction)) } - + # offset quadrants - #lr <- subset(x.sorted, type %in% c("cr", "cl") & quadrant=="lr") - #ol <- lr[, c("str.3.x0", "str.3.y0", "str.3.x1", "str.3.y1")] + # lr <- subset(x.sorted, type %in% c("cr", "cl") & quadrant=="lr") + # ol <- lr[, c("str.3.x0", "str.3.y0", "str.3.x1", "str.3.y1")] + + # order.lines <- 1:nrow(ol) + # order.lines <- rev(order.lines) - #order.lines <- 1:nrow(ol) - #order.lines <- rev(order.lines) - # lim <- c(min(ol), max(ol)) # plot(0, type="n", xlim=lim, ylim=lim) # rect(ol[,1], ol[,2], ol[,3], ol[,4]) # text(ol[,1], ol[,2], order.lines) - - offsetQuadrant <- function(x, quadrant="ur", direction=1, - reverse=T, margin=0.02){ - index <- x$type %in% c("cr", "cl") & x$quadrant==quadrant # get constructs of quandrant - + + offsetQuadrant <- function(x, quadrant = "ur", direction = 1, + reverse = T, margin = 0.02) { + index <- x$type %in% c("cr", "cl") & x$quadrant == quadrant # get constructs of quandrant + ol <- x[index, ] vars <- c("str.3.x0", "str.3.y0", "str.3.x1", "str.3.y1") - + order.lines <- 1:nrow(ol) - if (reverse) + if (reverse) { order.lines <- rev(order.lines) - - for (i in order.lines){ - for (i.n in order.lines){ - if(i != i.n){ + } + + for (i in order.lines) { + for (i.n in order.lines) { + if (i != i.n) { overlap <- doRectanglesOverlap(ol[i, vars], ol[i.n, vars]) - if (overlap){ # if overlap is present the rectangles is moved to avoid overlap - offset <- necessaryOffset(ol[i, vars], ol[i.n, vars], dir=direction, margin=margin) - ol[i.n, c("str.3.y", "str.3.y0","str.3.y1")] <- - ol[i.n, c("str.3.y", "str.3.y0", "str.3.y1")] + offset + if (overlap) { # if overlap is present the rectangles is moved to avoid overlap + offset <- necessaryOffset(ol[i, vars], ol[i.n, vars], dir = direction, margin = margin) + ol[i.n, c("str.3.y", "str.3.y0", "str.3.y1")] <- + ol[i.n, c("str.3.y", "str.3.y0", "str.3.y1")] + offset } } } } - + x[index, c("str.3.y", vars)] <- ol[, c("str.3.y", vars)] x } - + # code is slow! - if (outer.positioning){ - x <- offsetQuadrant(x, quadrant="ur", direction=1, reverse=F) #dir.ur <- 1; reverse <- F - x <- offsetQuadrant(x, quadrant="ul", direction=1, reverse=T) #dir.ul <- 1; reverse <- T - x <- offsetQuadrant(x, quadrant="ll", direction=-1, reverse=F) #dir.ll <- -1; reverse <- F - x <- offsetQuadrant(x, quadrant="lr", direction=-1, reverse=T) #dir.lr <- -1; reverse <- T + if (outer.positioning) { + x <- offsetQuadrant(x, quadrant = "ur", direction = 1, reverse = F) # dir.ur <- 1; reverse <- F + x <- offsetQuadrant(x, quadrant = "ul", direction = 1, reverse = T) # dir.ul <- 1; reverse <- T + x <- offsetQuadrant(x, quadrant = "ll", direction = -1, reverse = F) # dir.ll <- -1; reverse <- F + x <- offsetQuadrant(x, quadrant = "lr", direction = -1, reverse = T) # dir.lr <- -1; reverse <- T } - # + # # for (i in order.lines){ # #cat("---\n") # for (i.n in order.lines){ # if(i != i.n){ # overlap <- doRectanglesOverlap(ol[i, ], ol[i.n, ]) # #cat("(", i, i.n, ")", "\t\t"); print(overlap) - # if (overlap){ # if overlap is present the rectangles is moved to avoid overlap + # if (overlap){ # if overlap is present the rectangles is moved to avoid overlap # offset <- necessaryOffset(ol[i, ], ol[i.n, ], dir=-1, margin=0.02) # #print(offset) - # ol[i.n, c("str.3.y0","str.3.y1")] <- + # ol[i.n, c("str.3.y0","str.3.y1")] <- # ol[i.n, c("str.3.y0","str.3.y1")] + offset # } # } @@ -950,127 +997,144 @@ biplotDraw <- function(x, # lim <- c(min(ol), max(ol)) # rect(ol[,1], ol[,2], ol[,3], ol[,4], border="blue", lty=2) # text(ol[,3], ol[,2], order.lines, col="blue" ) - # - # + # + # # plot(0:5) # rect(ol[4,1],ol[4,2],ol[4,3],ol[4,4]) # rect(ol[3,1],ol[3,2],ol[3,3],ol[3,4]) # doRectanglesOverlap(ol[4,], ol[3,]) # do others overlap? If yes move them - - # make outer strokes for all labels (elements and constructs) + + # make outer strokes for all labels (elements and constructs) # select which to draw later # coordinates for stroke starts - str.1 <- calcCoordsBorders(x["x"], x["y"], xmax=max.ext, ymax=max.ext) + str.1 <- calcCoordsBorders(x["x"], x["y"], xmax = max.ext, ymax = max.ext) colnames(str.1) <- c("str.1.x", "str.1.y") - + # coordinates for stroke ends - str.2 <- calcCoordsBorders(x["x"], x["y"], xmax=max.ext * (1 + strokes.x), - ymax=max.ext * (1 + strokes.y)) + str.2 <- calcCoordsBorders(x["x"], x["y"], + xmax = max.ext * (1 + strokes.x), + ymax = max.ext * (1 + strokes.y) + ) colnames(str.2) <- c("str.2.x", "str.2.y") - + x <- cbind(x, str.1, str.2) - + # redo coordinates for stroke ends according to edges of rectangles that have been offsetted a <- list() - for (i in seq_len(nrow(x))){ - a[[i]] <- calcCoordsBorders(x[i, "x"], x[i, "y"], xmax=max.ext * (1 + strokes.x), - ymax=abs(x[i, "str.3.y"])) + for (i in seq_len(nrow(x))) { + a[[i]] <- calcCoordsBorders(x[i, "x"], x[i, "y"], + xmax = max.ext * (1 + strokes.x), + ymax = abs(x[i, "str.3.y"]) + ) } str.4 <- do.call(rbind, a) colnames(str.4) <- c("str.4.x", "str.4.y") x <- cbind(x, str.4) - if (!c.labels.inside){ # when constructs labels are prompted to be outside the plot(default) + if (!c.labels.inside) { # when constructs labels are prompted to be outside the plot(default) # rotate labels srt degress on top and bottom for quick printing - y.max.ext <- max.ext * (1 + strokes.y + offset.labels) # position of outer strokes to determine side of labels - x$rotate <- 0 # default is no rotation of labels in text - if (!outer.positioning) # only for positioning = FALSE to get neater label directions - x$rotate[x$str.3.y == y.max.ext | # replace by standadrd rotation angle - x$str.3.y == -y.max.ext] <- srt - + y.max.ext <- max.ext * (1 + strokes.y + offset.labels) # position of outer strokes to determine side of labels + x$rotate <- 0 # default is no rotation of labels in text + if (!outer.positioning) { # only for positioning = FALSE to get neater label directions + x$rotate[x$str.3.y == y.max.ext | # replace by standadrd rotation angle + x$str.3.y == -y.max.ext] <- srt + } + # only make labels, rectangles and strokes that are prompted - cl <- subset(x, type %in% c("cl", "cr") & showlabel==T) # select only labels that should be shown - segments(cl$str.1.x, cl$str.1.y, cl$str.2.x, cl$str.2.y, xpd=T) - segments(cl$str.2.x, cl$str.2.y, cl$str.4.x, cl$str.4.y, xpd=T, lty=3) - rect(cl$str.3.x0, cl$str.3.y0, - cl$str.3.x1, cl$str.3.y1, col=grey(1), border=grey(1), xpd=T) + cl <- subset(x, type %in% c("cl", "cr") & showlabel == T) # select only labels that should be shown + segments(cl$str.1.x, cl$str.1.y, cl$str.2.x, cl$str.2.y, xpd = T) + segments(cl$str.2.x, cl$str.2.y, cl$str.4.x, cl$str.4.y, xpd = T, lty = 3) + rect(cl$str.3.x0, cl$str.3.y0, + cl$str.3.x1, cl$str.3.y1, + col = grey(1), border = grey(1), xpd = T + ) # print constructs labels (if there are any) and not only inner labels are prompted - if (nrow(cl) > 0){ - for (i in 1:nrow(cl)){ - if (cl$str.3.x[i] < 0) - adj <- c(1, .5) else + if (nrow(cl) > 0) { + for (i in 1:nrow(cl)) { + if (cl$str.3.x[i] < 0) { + adj <- c(1, .5) + } else { adj <- c(0, .5) - if (!outer.positioning){ # overwrite adj in case of no positioning - if (cl$str.3.y[i] == y.max.ext) + } + if (!outer.positioning) { # overwrite adj in case of no positioning + if (cl$str.3.y[i] == y.max.ext) { adj <- c(0, .5) - if (cl$str.3.y[i] == -y.max.ext) + } + if (cl$str.3.y[i] == -y.max.ext) { adj <- c(1, .5) + } } - text(cl$str.3.x[i], cl$str.3.y[i], labels=cl$label[i], col=cl$label.col[i], - cex=cl$label.cex[i], adj=adj, xpd=T, srt=cl$rotate[i]) + text(cl$str.3.x[i], cl$str.3.y[i], + labels = cl$label[i], col = cl$label.col[i], + cex = cl$label.cex[i], adj = adj, xpd = T, srt = cl$rotate[i] + ) } } } - - + + ### plotting of elements and constructs inside plot ### - - #make construct lines if prompted - if (c.lines){ - cli <- subset(x, type %in% c("cl", "cr") & showlabel==T) # select only labels that should be shown - segments(0, 0, cli$str.1.x, cli$str.1.y, col=col.c.lines) # lines form biplot center to outsides + + # make construct lines if prompted + if (c.lines) { + cli <- subset(x, type %in% c("cl", "cr") & showlabel == T) # select only labels that should be shown + segments(0, 0, cli$str.1.x, cli$str.1.y, col = col.c.lines) # lines form biplot center to outsides } # make construct symbols - cs <- subset(x, type %in% c("cl", "cr") & showpoint==T & abs(x) 0) - text(es[, c("x.pos", "y.pos")], - labels=es$label, col=es$label.col, pch=15, cex=es$label.cex, xpd=xpd) - + x$showlabel[is.na(x$showlabel)] <- TRUE + x$showpoint[is.na(x$showpoint)] <- TRUE + + sh <- subset(x, showlabel == T & showpoint == T) # & + lpos <- pointLabel(sh[c("x", "y")], labels = sh$label, doPlot = FALSE, cex = cex.pos) # package maptools + x$x.pos <- NA + x$y.pos <- NA + sh$x.pos <- lpos$x + sh$y.pos <- lpos$y + x[x$showlabel == T & x$showpoint == T, ] <- sh + } else { # simple offsetting in y direction + x$x.pos <- x$x + x$y.pos <- NA + offset.y.pos <- strheight("aaaa", cex = .7) # string height for dummy string + x[x$type == "e", ]$y.pos <- x[x$type == "e", ]$y + offset.y.pos * offset.e # offset element labels by normal stringheight times x + x[x$type %in% c("cl", "cr"), ]$y.pos <- x[x$type %in% c("cl", "cr"), ]$y - .05 + } + + # text labels for elements + # es <- subset(x, type=="e" & showlabel==T & showpoint==T) # old version + es <- subset(x, type == "e" & showlabel == T & showpoint == T & + abs(x) < max.ext & abs(y) < max.ext) # avoid plotting outside plot region + if (dim(es)[1] > 0) { + text(es[, c("x.pos", "y.pos")], + labels = es$label, col = es$label.col, pch = 15, cex = es$label.cex, xpd = xpd + ) + } + # text labels for constructs inside plot - if (c.labels.inside){ - cs <- subset(x, type %in% c("cl", "cr") & showlabel==T - & abs(x) 0) - text(cs[, c("x.pos", "y.pos")], - labels=cs$label, col=cs$label.col, pch=4, cex=cs$label.cex, xpd=xpd) + if (c.labels.inside) { + cs <- subset(x, type %in% c("cl", "cr") & showlabel == T & + abs(x) < max.ext & abs(y) < max.ext) + if (dim(cs)[1] > 0) { + text(cs[, c("x.pos", "y.pos")], + labels = cs$label, col = cs$label.col, pch = 4, cex = cs$label.cex, xpd = xpd + ) + } } - invisible(x) # returns plotdata frame + invisible(x) # returns plotdata frame } # x <- calcBiplotCoords(raeithel, g=1, h=1) # x <- prepareBiplotData(x) @@ -1080,78 +1144,84 @@ biplotDraw <- function(x, #' Adds the percentage of the sum-of-squares explained by each axis to the plot. -#' -#' @param x `repgrid` object containing the biplot coords, i.e. after -#' having called [calcBiplotCoords()] and +#' +#' @param x `repgrid` object containing the biplot coords, i.e. after +#' having called [calcBiplotCoords()] and #' [prepareBiplotData()]. #' @param dim The dimensions to be printed. -#' @param var.show Show explained sum-of-squares in biplot? (default `TRUE`). +#' @param var.show Show explained sum-of-squares in biplot? (default `TRUE`). #' @param var.cex The cex value for the percentages shown in the plot. #' @param var.col The color value of the percentages shown in the plot. -#' @param axis.ext Axis extension factor (default is `.1`). A bigger value will +#' @param axis.ext Axis extension factor (default is `.1`). A bigger value will #' zoom out the plot. -#' @param center Numeric. The type of centering to be performed. -#' 0= no centering, 1= row mean centering (construct), +#' @param center Numeric. The type of centering to be performed. +#' 0= no centering, 1= row mean centering (construct), #' 2= column mean centering (elements), 3= double-centering (construct and element means), #' 4= midpoint centering of rows (constructs). #' The default is `1` (row centering). #' @param normalize A numeric value indicating along what direction (rows, columns) #' to normalize by standard deviations. `0 = none, 1= rows, 2 = columns` #' (default is `0`). -#' @param g Power of the singular value matrix assigned to the left singular +#' @param g Power of the singular value matrix assigned to the left singular #' vectors, i.e. the constructs. -#' @param h Power of the singular value matrix assigned to the right singular +#' @param h Power of the singular value matrix assigned to the right singular #' vectors, i.e. the elements. #' @param col.active Columns (elements) that are no supplementary points, i.e. they are used #' in the SVD to find principal components. default is to use all elements. #' @param col.passive Columns (elements) that are supplementary points, i.e. they are NOT used -#' in the SVD but projected into the component space afterwards. They do not -#' determine the solution. Default is `NA`, i.e. no elements are set +#' in the SVD but projected into the component space afterwards. They do not +#' determine the solution. Default is `NA`, i.e. no elements are set #' supplementary. #' @param ... Not evaluated. #' @keywords internal #' @export #' -addVarianceExplainedToBiplot2d <- function(x, dim=c(1,2,3), var.cex=.7, - var.show=TRUE, var.col=grey(.1), - axis.ext = .1, - center=1, normalize=0, - g=0, h=1-g, - col.active=NA, - col.passive=NA, - ...){ +addVarianceExplainedToBiplot2d <- function(x, dim = c(1, 2, 3), var.cex = .7, + var.show = TRUE, var.col = grey(.1), + axis.ext = .1, + center = 1, normalize = 0, + g = 0, h = 1 - g, + col.active = NA, + col.passive = NA, + ...) { # do only if prompted - if (var.show){ - # determine way to calculate SSQ proportions. + if (var.show) { + # determine way to calculate SSQ proportions. # Different if passive columns are used. - if(is.na(col.active[1]) & is.na(col.passive[1])) - standard.calc.ssq <- TRUE else + if (is.na(col.active[1]) & is.na(col.passive[1])) { + standard.calc.ssq <- TRUE + } else { standard.calc.ssq <- FALSE - - if (standard.calc.ssq){ + } + + if (standard.calc.ssq) { # one valid way of calculating the prop SSQ not taking into account passive columns - sv <- x@calcs$biplot$D # get singular values from SVD - sv.exp <- sv^2/sum(sv^2) # proportion of ssq explained per principal component - var <- paste("Dim ", dim[1:2], ": ", round(sv.exp[dim[1:2]] * 100, 1), "%", sep="") + sv <- x@calcs$biplot$D # get singular values from SVD + sv.exp <- sv^2 / sum(sv^2) # proportion of ssq explained per principal component + var <- paste("Dim ", dim[1:2], ": ", round(sv.exp[dim[1:2]] * 100, 1), "%", sep = "") } else { # calculating explained variance when passive columns are used - ssq.out <- ssq(x, along=2, cum=F, g=g, h=h, - center=center, normalize=normalize, - col.active=col.active, - col.passive=col.passive, print=F, ...) + ssq.out <- ssq(x, + along = 2, cum = F, g = g, h = h, + center = center, normalize = normalize, + col.active = col.active, + col.passive = col.passive, print = F, ... + ) ssq.prop.dim <- ssq.out[dim(ssq.out)[1], dim] - var <- paste("Dim ", dim[1:2], ": ", - round(ssq.prop.dim[dim[1:2]], 1), "%", sep="") - } - data <- x@plotdata # data frame from data prepare function return + var <- paste("Dim ", dim[1:2], ": ", + round(ssq.prop.dim[dim[1:2]], 1), "%", + sep = "" + ) + } + data <- x@plotdata # data frame from data prepare function return max.all <- max(abs(data$x), abs(data$y)) axis.ext <- 1 + axis.ext max.ext <- max.all * axis.ext - - ext <- strheight(var[1], cex=var.cex) - - text(max.ext - ext/2, 0, var[1] , cex=var.cex, adj=c(.5,0), col=var.col, srt=90) - text(0, -max.ext + ext/2, var[2] , cex=var.cex, adj=c(.5,0), col=var.col) + + ext <- strheight(var[1], cex = var.cex) + + text(max.ext - ext / 2, 0, var[1], cex = var.cex, adj = c(.5, 0), col = var.col, srt = 90) + text(0, -max.ext + ext / 2, var[2], cex = var.cex, adj = c(.5, 0), col = var.col) } } @@ -1161,22 +1231,22 @@ addVarianceExplainedToBiplot2d <- function(x, dim=c(1,2,3), var.cex=.7, # xb <- prepareBiplotData(x, c.labels.show=F, c.points.dev=90, e.points=1:3, e.labels=T) # biplotDraw(xb, xpd=F, inner=F, outer=F) # addVarianceExplainedToBiplot(xb$rg, xb$df) -# +# # xb <- prepareBiplotData(x, c.points.dev=5, c.labels.dev=5) # biplotDraw(xb, xpd=F, inner=F, outer=T, mai=rep(0,4), c.labels.inside=T) # biplotDraw(xb, xpd=F, inner=F, outer=T) -# +# # dev.new() # xb <- prepareBiplotData(x, dim=c(1,2), map=4) # biplotDraw(xb, dev=15) # addVarianceExplainedToBiplot(x, xb, dim=c(1,2,4)) -# -# +# +# # dev.new() # xb <- prepareBiplotData(x, dim=c(2,3), map=1) # biplotDraw(xb, dev=15) # addVarianceExplainedToBiplot(x, xb, dim=c(2,3,1)) -# +# # dev.new() # xb <- prepareBiplotData(x, dim=c(3,4), map=1) # biplotDraw(xb, dev=15) @@ -1186,37 +1256,37 @@ addVarianceExplainedToBiplot2d <- function(x, dim=c(1,2,3), var.cex=.7, # x <- prepareBiplotData(x, e.col="black", c.col="black", cex.e=.7, cex.c=.7)#, color.e=.8, color.c=.8) # biplotDraw(x) # addVarianceExplainedToBiplot(boeker, x) -# +# # x <- boeker -# x <- prepareBiplotData(x, e.col="black", c.col="black", cex.e=.7, cex.c=.7, +# x <- prepareBiplotData(x, e.col="black", c.col="black", cex.e=.7, cex.c=.7, # color.e=.3, color.c=.5) # biplotDraw(x) # addVarianceExplainedToBiplot(boeker, x) -# +# # x <- boeker # x <- prepareBiplotData(x, e.col="black", c.col="black", cex.e=c(.3,1)) # x <- prepareBiplotData(x, e.col="black", c.col="black", cex.e=c(.3,1), cex.c=c(.3,1)) # x <- prepareBiplotData(x, cex.e=c(.5,1.3), cex.c=c(.5,1.3)) # x <- prepareBiplotData(x, cex.e=c(.5,1), cex.c=c(.5,1), color.c.map=c(0, 0)) # biplotDraw2(x) -# +# # x <- boeker # x <- raeithel -# +# # layout(matrix(1:4, by=T, ncol=2)) -# +# # xb <- prepareBiplotData(x, dim=c(1,2), map=3) # biplotDraw(xb) # addVarianceExplainedToBiplot(x, xb, dim=1:3) -# +# # xb <- prepareBiplotData(x, dim=c(2,3), map=1) # biplotDraw(xb) # addVarianceExplainedToBiplot(x, xb, dim=c(2,3,1)) -# +# # xb <- prepareBiplotData(x, dim=c(3,4), map=1) # biplotDraw(xb) # addVarianceExplainedToBiplot(x, xb, dim=c(3,4,1)) -# +# # xb <- prepareBiplotData(x, dim=c(1,4), map=2) # biplotDraw(xb) # addVarianceExplainedToBiplot(x, xb, dim=c(1,4,2)) @@ -1233,152 +1303,152 @@ addVarianceExplainedToBiplot2d <- function(x, dim=c(1,2,3), var.cex=.7, #' example section below to get started. #' #' For the construction of a biplot the grid matrix is first centered and normalized according to the prompted options. -#' +#' #' Next, the matrix is decomposed by singular value decomposition (SVD) #' into \deqn{X = UDV^T}{X = UDV^T} -#' The biplot is made up of two matrices +#' The biplot is made up of two matrices #' \deqn{X = GH^T}{X = GH^T} #' These matrices are construed on the basis of the SVD results. #' \deqn{\hat{X} = UD^gD^hV^T}{X = UD^gD^hV^T} -#' Note that the grid matrix values are only recovered and +#' Note that the grid matrix values are only recovered and #' the projection property is only given if \eqn{g + h = 1}{g + h = 1} -#' +#' #' #' @param x `repgrid` object. -#' @param dim Dimensions (i.e. principal components) to be used for biplot +#' @param dim Dimensions (i.e. principal components) to be used for biplot #' (default is `c(1,2)`). #' @param map.dim Third dimension (depth) used to map aesthetic attributes to #' (default is `3`). -#' @param center Numeric. The type of centering to be performed. -#' 0= no centering, 1= row mean centering (construct), +#' @param center Numeric. The type of centering to be performed. +#' 0= no centering, 1= row mean centering (construct), #' 2= column mean centering (elements), 3= double-centering (construct and element means), #' 4= midpoint centering of rows (constructs). #' The default is `1` (row centering). #' @param normalize A numeric value indicating along what direction (rows, columns) #' to normalize by standard deviations. `0 = none, 1= rows, 2 = columns` #' (default is `0`). -#' @param g Power of the singular value matrix assigned to the left singular +#' @param g Power of the singular value matrix assigned to the left singular #' vectors, i.e. the constructs. -#' @param h Power of the singular value matrix assigned to the right singular +#' @param h Power of the singular value matrix assigned to the right singular #' vectors, i.e. the elements. #' @param col.active Columns (elements) that are no supplementary points, i.e. they are used #' in the SVD to find principal components. default is to use all elements. #' @param col.passive Columns (elements) that are supplementary points, i.e. they are NOT used -#' in the SVD but projected into the component space afterwards. They do not -#' determine the solution. Default is `NA`, i.e. no elements are set +#' in the SVD but projected into the component space afterwards. They do not +#' determine the solution. Default is `NA`, i.e. no elements are set #' supplementary. #' @param e.point.col Color of the element symbols. The default is `"black"`. -#' Two values can be entered that will create a color ramp. The values of +#' Two values can be entered that will create a color ramp. The values of #' `map.dim` are mapped onto the ramp. -#' If only one color color value is supplied (e.g. `"black"`) -#' no mapping occurs and all elements will have the same color +#' If only one color color value is supplied (e.g. `"black"`) +#' no mapping occurs and all elements will have the same color #' irrespective of their value on the `map.dim` dimension. #' @param e.point.cex Size of the element symbols. The default is `.9`. -#' Two values can be entered that will create a size ramp. The values of +#' Two values can be entered that will create a size ramp. The values of #' `map.dim` are mapped onto the ramp. -#' If only one color size value is supplied (e.g. `.8`) -#' no mapping occurs and all elements will have the same size +#' If only one color size value is supplied (e.g. `.8`) +#' no mapping occurs and all elements will have the same size #' irrespective of their value on the `map.dim` dimension. #' @param e.label.col Color of the element label. The default is `"black"`. -#' Two values can be entered that will create a color ramp. The values of +#' Two values can be entered that will create a color ramp. The values of #' `map.dim` are mapped onto the ramp. -#' If only one color color value is supplied (e.g. `"black"`) -#' no mapping occurs and all labels will have the same color +#' If only one color color value is supplied (e.g. `"black"`) +#' no mapping occurs and all labels will have the same color #' irrespective of their value on the `map.dim` dimension. #' @param e.label.cex Size of the element labels. The default is `.7`. -#' Two values can be entered that will create a size ramp. The values of +#' Two values can be entered that will create a size ramp. The values of #' `map.dim` are mapped onto the ramp. -#' If only one color size value is supplied (e.g. `.7`) -#' no mapping occurs and all labels will have the same size +#' If only one color size value is supplied (e.g. `.7`) +#' no mapping occurs and all labels will have the same size #' irrespective of their value on the `map.dim` dimension. -#' @param e.color.map Value range to determine what range of the color ramp defined in -#' `e.color` will be used for mapping the colors. -#' Default is `c(.4, ,1)`. Usually not important for the user. +#' @param e.color.map Value range to determine what range of the color ramp defined in +#' `e.color` will be used for mapping the colors. +#' Default is `c(.4, ,1)`. Usually not important for the user. #' @param c.point.col Color of the construct symbols. The default is `"black"`. -#' Two values can be entered that will create a color ramp. The values of +#' Two values can be entered that will create a color ramp. The values of #' `map.dim` are mapped onto the ramp. -#' If only one color color value is supplied (e.g. `"black"`) -#' no mapping occurs and all construct will have the same color +#' If only one color color value is supplied (e.g. `"black"`) +#' no mapping occurs and all construct will have the same color #' irrespective of their value on the `map.dim` dimension. #' @param c.point.cex Size of the construct symbols. The default is `.8`. -#' Two values can be entered that will create a size ramp. The values of +#' Two values can be entered that will create a size ramp. The values of #' `map.dim` are mapped onto the ramp. -#' If only one color size value is supplied (e.g. `.8`) -#' no mapping occurs and all construct will have the same size +#' If only one color size value is supplied (e.g. `.8`) +#' no mapping occurs and all construct will have the same size #' irrespective of their value on the `map.dim` dimension. #' @param c.label.col Color of the construct label. The default is `"black"`. -#' Two values can be entered that will create a color ramp. The values of +#' Two values can be entered that will create a color ramp. The values of #' `map.dim` are mapped onto the ramp. -#' If only one color color value is supplied (e.g. `"black"`) -#' no mapping occurs and all labels will have the same color +#' If only one color color value is supplied (e.g. `"black"`) +#' no mapping occurs and all labels will have the same color #' irrespective of their value on the `map.dim` dimension. #' @param c.label.cex Size of the construct labels. The default is `.7`. -#' Two values can be entered that will create a size ramp. The values of +#' Two values can be entered that will create a size ramp. The values of #' `map.dim` are mapped onto the ramp. -#' If only one color size value is supplied (e.g. `.7`) -#' no mapping occurs and all labels will have the same size +#' If only one color size value is supplied (e.g. `.7`) +#' no mapping occurs and all labels will have the same size #' irrespective of their value on the `map.dim` dimension. -#' @param c.color.map Value range to determine what range of the color ramp defined in +#' @param c.color.map Value range to determine what range of the color ramp defined in #' `c.color` will be used for mapping. Default is `c(.4, ,1)`. #' Usually not important for the user. #' @param c.points.devangle The deviation angle from the x-y plane in degrees. These can only be calculated -#' if a third dimension `map.dim` is specified. Only the constructs -#' that do not depart more than the specified degrees from the -#' x-y plane will be printed. This facilitates the visual -#' interpretation, as only vectors represented near the current plane -#' are shown. Set the value to `91` (default) +#' if a third dimension `map.dim` is specified. Only the constructs +#' that do not depart more than the specified degrees from the +#' x-y plane will be printed. This facilitates the visual +#' interpretation, as only vectors represented near the current plane +#' are shown. Set the value to `91` (default) #' to show all vectors. #' @param c.labels.devangle The deviation angle from the x-y plane in degrees. These can only be calculated -#' if a third dimension `map.dim` is specified. Only the labels of constructs -#' that do not depart more than the specified degrees from the -#' x-y plane will be printed. Set the value to `91` (default) +#' if a third dimension `map.dim` is specified. Only the labels of constructs +#' that do not depart more than the specified degrees from the +#' x-y plane will be printed. Set the value to `91` (default) #' to show all construct labels. #' @param c.points.show Whether the constructs are printed (default is `TRUE`). #' `FALSE` will suppress the printing of the constructs. -#' To only print certain constructs a numeric vector can be +#' To only print certain constructs a numeric vector can be #' provided (e.g. `c(1:10)`). #' @param c.labels.show Whether the construct labels are printed (default is `TRUE`). #' `FALSE` will suppress the printing of the labels. -#' To only print certain construct labels a numeric vector can be +#' To only print certain construct labels a numeric vector can be #' provided (e.g. `c(1:10)`). #' @param e.points.show Whether the elements are printed (default is `TRUE`). #' `FALSE` will suppress the printing of the elements. -#' To only print certain elements a numeric vector can be +#' To only print certain elements a numeric vector can be #' provided (e.g. `c(1:10)`). #' @param e.labels.show Whether the element labels are printed (default is `TRUE`). #' `FALSE` will suppress the printing of the labels. -#' To only print certain element labels a numeric vector can be +#' To only print certain element labels a numeric vector can be #' provided (e.g. `c(1:10)`). -#' @param inner.positioning Logical. Whether to calculate positions to minimize overplotting of +#' @param inner.positioning Logical. Whether to calculate positions to minimize overplotting of #' elements and construct labels (default is`TRUE`). Note that #' the positioning may slow down the plotting. -#' @param outer.positioning Logical. Whether to calculate positions to minimize overplotting of +#' @param outer.positioning Logical. Whether to calculate positions to minimize overplotting of #' of construct labels on the outer borders (default is`TRUE`). Note that #' the positioning may slow down the plotting. #' @param c.labels.inside Logical. Whether to print construct labels next to the points. #' Can be useful during inspection of the plot (default `FALSE`). #' @param c.lines Logical. Whether construct lines from the center of the biplot #' to the surrounding box are drawn (default is `FALSE`). -#' @param col.c.lines The color of the construct lines from the center to the borders +#' @param col.c.lines The color of the construct lines from the center to the borders #' of the plot (default is `gray(.9)`). -#' @param flipaxes Logical vector of length two. Whether x and y axes are reversed +#' @param flipaxes Logical vector of length two. Whether x and y axes are reversed #' (default is `c(F,F)`). -#' @param strokes.x Length of outer strokes in x direction in NDC. +#' @param strokes.x Length of outer strokes in x direction in NDC. #' @param strokes.y Length of outer strokes in y direction in NDC. #' @param offsetting Do offsetting? (TODO) #' @param offset.labels Offsetting parameter for labels (TODO). #' @param offset.e offsetting parameter for elements (TODO). -#' @param axis.ext Axis extension factor (default is `.1`). A bigger value will +#' @param axis.ext Axis extension factor (default is `.1`). A bigger value will #' zoom out the plot. -#' @param mai Margins available for plotting the labels in inch +#' @param mai Margins available for plotting the labels in inch #' (default is `c(.2, 1.5, .2, 1.5)`). #' @param rect.margins Vector of length two (default is `c(.07, .07)`). Two values -#' specifying the additional horizontal and vertical margin around each -#' label. +#' specifying the additional horizontal and vertical margin around each +#' label. #' @param srt Angle to rotate construct label text. Only used in case `offsetting=FALSE`. #' @param cex.pos Cex parameter used during positioning of labels if prompted. Does #' usually not have to be changed by user. -#' @param xpd Logical (default is `TRUE`). Whether to extend text labels +#' @param xpd Logical (default is `TRUE`). Whether to extend text labels #' over figure region. Usually not needed by the user. #' @param unity Scale elements and constructs coordinates to unit scale in 2D (maximum of 1) #' so they are printed more neatly (default `TRUE`). @@ -1389,154 +1459,164 @@ addVarianceExplainedToBiplot2d <- function(x, dim=c(1,2,3), var.cex=.7, #' This argument is for visual appeal only. #' @param zoom Scaling factor for all vectors. Can be used to zoom #' the plot in and out (default `1`). -#' @param var.show Show explained sum-of-squares in biplot? (default `TRUE`). +#' @param var.show Show explained sum-of-squares in biplot? (default `TRUE`). #' @param var.cex The cex value for the percentages shown in the plot. #' @param var.col The color value of the percentages shown in the plot. #' @param ... parameters passed on to come. #' @export #' @seealso #' - Unsophisticated biplot: [biplotSimple()]; -#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; -#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; -#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; +#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; +#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; +#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; #' - Function to set view in 3D: [home()] #' #' @examples \dontrun{ #' -#' biplot2d(boeker) # biplot of boeker data -#' biplot2d(boeker, c.lines=T) # add construct lines -#' biplot2d(boeker, center=2) # with column centering -#' biplot2d(boeker, center=4) # midpoint centering -#' biplot2d(boeker, normalize=1) # normalization of constructs +#' biplot2d(boeker) # biplot of boeker data +#' biplot2d(boeker, c.lines = T) # add construct lines +#' biplot2d(boeker, center = 2) # with column centering +#' biplot2d(boeker, center = 4) # midpoint centering +#' biplot2d(boeker, normalize = 1) # normalization of constructs +#' +#' biplot2d(boeker, dim = 2:3) # plot 2nd and 3rd dimension +#' biplot2d(boeker, dim = c(1, 4)) # plot 1st and 4th dimension #' -#' biplot2d(boeker, dim=2:3) # plot 2nd and 3rd dimension -#' biplot2d(boeker, dim=c(1,4)) # plot 1st and 4th dimension +#' biplot2d(boeker, g = 1, h = 1) # assign singular values to con. & elem. +#' biplot2d(boeker, g = 1, h = 1, center = 1) # row centering (Slater) +#' biplot2d(boeker, g = 1, h = 1, center = 4) # midpoint centering (ESA) #' -#' biplot2d(boeker, g=1, h=1) # assign singular values to con. & elem. -#' biplot2d(boeker, g=1, h=1, center=1) # row centering (Slater) -#' biplot2d(boeker, g=1, h=1, center=4) # midpoint centering (ESA) +#' biplot2d(boeker, e.color = "red", c.color = "blue") # change colors +#' biplot2d(boeker, c.color = c("white", "darkred")) # mapped onto color range #' -#' biplot2d(boeker, e.color="red", c.color="blue") # change colors -#' biplot2d(boeker, c.color=c("white", "darkred")) # mapped onto color range -#' -#' biplot2d(boeker, unity=T) # scale con. & elem. to equal length -#' biplot2d(boeker, unity=T, scale.e=.5) # scaling factor for element vectors +#' biplot2d(boeker, unity = T) # scale con. & elem. to equal length +#' biplot2d(boeker, unity = T, scale.e = .5) # scaling factor for element vectors #' -#' biplot2d(boeker, e.labels.show=F) # do not show element labels -#' biplot2d(boeker, e.labels.show=c(1,2,4)) # show labels for elements 1, 2 and 4 -#' biplot2d(boeker, e.points.show=c(1,2,4)) # only show elements 1, 2 and 4 -#' biplot2d(boeker, c.labels.show=c(1:4)) # show constructs labels 1 to 4 -#' biplot2d(boeker, c.labels.show=c(1:4)) # show constructs labels except 1 to 4 +#' biplot2d(boeker, e.labels.show = F) # do not show element labels +#' biplot2d(boeker, e.labels.show = c(1, 2, 4)) # show labels for elements 1, 2 and 4 +#' biplot2d(boeker, e.points.show = c(1, 2, 4)) # only show elements 1, 2 and 4 +#' biplot2d(boeker, c.labels.show = c(1:4)) # show constructs labels 1 to 4 +#' biplot2d(boeker, c.labels.show = c(1:4)) # show constructs labels except 1 to 4 #' -#' biplot2d(boeker, e.cex.map=1) # change size of texts for elements -#' biplot2d(boeker, c.cex.map=1) # change size of texts for constructs +#' biplot2d(boeker, e.cex.map = 1) # change size of texts for elements +#' biplot2d(boeker, c.cex.map = 1) # change size of texts for constructs #' -#' biplot2d(boeker, g=1, h=1, c.labels.inside=T) # constructs inside the plot -#' biplot2d(boeker, g=1, h=1, c.labels.inside=T, # different margins and elem. color -#' mai=c(0,0,0,0), e.color="red") -#' -#' biplot2d(boeker, strokes.x=.3, strokes.y=.05) # change length of strokes +#' biplot2d(boeker, g = 1, h = 1, c.labels.inside = T) # constructs inside the plot +#' biplot2d(boeker, +#' g = 1, h = 1, c.labels.inside = T, # different margins and elem. color +#' mai = c(0, 0, 0, 0), e.color = "red" +#' ) #' -#' biplot2d(boeker, flipaxes=c(T, F)) # flip x axis -#' biplot2d(boeker, flipaxes=c(T, T)) # flip x and y axis +#' biplot2d(boeker, strokes.x = .3, strokes.y = .05) # change length of strokes #' -#' biplot2d(boeker, outer.positioning=F) # no positioning of con.-labels +#' biplot2d(boeker, flipaxes = c(T, F)) # flip x axis +#' biplot2d(boeker, flipaxes = c(T, T)) # flip x and y axis #' -#' biplot2d(boeker, c.labels.devangle=20) # only con. within 20 degree angle +#' biplot2d(boeker, outer.positioning = F) # no positioning of con.-labels +#' +#' biplot2d(boeker, c.labels.devangle = 20) # only con. within 20 degree angle #' } -#' -biplot2d <- function(x, dim=c(1,2), map.dim=3, - center=1, - normalize=0, - g=0, - h=1-g, - col.active=NA, - col.passive=NA, - #e.color="black", - #c.color="black", - e.point.col="black", - e.point.cex=.9, - e.label.col="black", - e.label.cex=.7, - e.color.map=c(.4, 1), - c.point.col="black", - c.point.cex=0, # construct positions are not displayed by default - c.label.col="black", - c.label.cex=.7, - c.color.map=c(.4, 1), - #e.cex.map=.7, - #c.cex.map=.7, - c.points.devangle=91, - c.labels.devangle=91, - c.points.show=TRUE, - c.labels.show=TRUE, - e.points.show=TRUE, - e.labels.show=TRUE, - inner.positioning=TRUE, - outer.positioning=TRUE, - c.labels.inside=FALSE, - c.lines=TRUE, - col.c.lines=grey(.9), - flipaxes=c(FALSE,FALSE), - strokes.x=.1, strokes.y=.1, - offsetting=TRUE, offset.labels=.0, offset.e= 1, - axis.ext=.1, mai=c(.2, 1.5, .2, 1.5), - rect.margins=c(.01, .01), - srt=45, - cex.pos=.7, - xpd=TRUE, - unity=FALSE, - unity3d=FALSE, - scale.e=.9, - zoom=1, - var.show=TRUE, - var.cex=.7, - var.col=grey(.1), - ...) { - x <- calcBiplotCoords(x, center=center, normalize=normalize, - g=g, h=h, - col.active=col.active, col.passive=col.passive, ...) - x <- prepareBiplotData(x, dim=dim, map.dim=map.dim, - e.label.cex=e.label.cex, c.label.cex=c.label.cex, - e.label.col=e.label.col, c.label.col=c.label.col, - e.point.cex=e.point.cex, c.point.cex=c.point.cex, - e.point.col=e.point.col, c.point.col=c.point.col, - #e.color=e.color, c.color=c.color, - #e.cex.map=e.cex.map, c.cex.map=c.cex.map, - e.color.map=e.color.map, c.color.map=c.color.map, - c.points.devangle=c.points.devangle, - c.labels.devangle=c.labels.devangle, c.points.show=c.points.show, - c.labels.show=c.labels.show, - e.points.show=e.points.show, - e.labels.show=e.labels.show, - unity=unity, unity3d=unity3d, scale.e=scale.e, ...) - biplotDraw(x, inner.positioning=inner.positioning, outer.positioning=outer.positioning, - c.labels.inside=c.labels.inside, - c.lines=c.lines, col.c.lines=col.c.lines, flipaxes=flipaxes, - strokes.x=strokes.x, strokes.y=strokes.y, - offsetting=offsetting, offset.labels=offset.labels, offset.e=offset.e, - axis.ext=axis.ext, mai=mai, rect.margins=rect.margins, - srt=srt, cex.pos=cex.pos, xpd=xpd, zoom=zoom) - addVarianceExplainedToBiplot2d(x, dim=dim, center=center, normalize=normalize, - g=g, h=h, col.active=col.active, - col.passive=col.passive, var.show=var.show, - var.cex=var.cex, var.col=var.col, ...) - invisible(NULL) +#' +biplot2d <- function(x, dim = c(1, 2), map.dim = 3, + center = 1, + normalize = 0, + g = 0, + h = 1 - g, + col.active = NA, + col.passive = NA, + # e.color="black", + # c.color="black", + e.point.col = "black", + e.point.cex = .9, + e.label.col = "black", + e.label.cex = .7, + e.color.map = c(.4, 1), + c.point.col = "black", + c.point.cex = 0, # construct positions are not displayed by default + c.label.col = "black", + c.label.cex = .7, + c.color.map = c(.4, 1), + # e.cex.map=.7, + # c.cex.map=.7, + c.points.devangle = 91, + c.labels.devangle = 91, + c.points.show = TRUE, + c.labels.show = TRUE, + e.points.show = TRUE, + e.labels.show = TRUE, + inner.positioning = TRUE, + outer.positioning = TRUE, + c.labels.inside = FALSE, + c.lines = TRUE, + col.c.lines = grey(.9), + flipaxes = c(FALSE, FALSE), + strokes.x = .1, strokes.y = .1, + offsetting = TRUE, offset.labels = .0, offset.e = 1, + axis.ext = .1, mai = c(.2, 1.5, .2, 1.5), + rect.margins = c(.01, .01), + srt = 45, + cex.pos = .7, + xpd = TRUE, + unity = FALSE, + unity3d = FALSE, + scale.e = .9, + zoom = 1, + var.show = TRUE, + var.cex = .7, + var.col = grey(.1), + ...) { + x <- calcBiplotCoords(x, + center = center, normalize = normalize, + g = g, h = h, + col.active = col.active, col.passive = col.passive, ... + ) + x <- prepareBiplotData(x, + dim = dim, map.dim = map.dim, + e.label.cex = e.label.cex, c.label.cex = c.label.cex, + e.label.col = e.label.col, c.label.col = c.label.col, + e.point.cex = e.point.cex, c.point.cex = c.point.cex, + e.point.col = e.point.col, c.point.col = c.point.col, + # e.color=e.color, c.color=c.color, + # e.cex.map=e.cex.map, c.cex.map=c.cex.map, + e.color.map = e.color.map, c.color.map = c.color.map, + c.points.devangle = c.points.devangle, + c.labels.devangle = c.labels.devangle, c.points.show = c.points.show, + c.labels.show = c.labels.show, + e.points.show = e.points.show, + e.labels.show = e.labels.show, + unity = unity, unity3d = unity3d, scale.e = scale.e, ... + ) + biplotDraw(x, + inner.positioning = inner.positioning, outer.positioning = outer.positioning, + c.labels.inside = c.labels.inside, + c.lines = c.lines, col.c.lines = col.c.lines, flipaxes = flipaxes, + strokes.x = strokes.x, strokes.y = strokes.y, + offsetting = offsetting, offset.labels = offset.labels, offset.e = offset.e, + axis.ext = axis.ext, mai = mai, rect.margins = rect.margins, + srt = srt, cex.pos = cex.pos, xpd = xpd, zoom = zoom + ) + addVarianceExplainedToBiplot2d(x, + dim = dim, center = center, normalize = normalize, + g = g, h = h, col.active = col.active, + col.passive = col.passive, var.show = var.show, + var.cex = var.cex, var.col = var.col, ... + ) + invisible(NULL) } #' Draws a biplot of the grid in 2D with depth impression (pseudo 3D). #' -#' This version is basically a 2D biplot. +#' This version is basically a 2D biplot. #' It only modifies color and size of the symbols in order to create a 3D impression -#' of the data points. -#' This function will call the standard [biplot2d()] function with some +#' of the data points. +#' This function will call the standard [biplot2d()] function with some #' modified arguments. For the whole set of arguments that can be used -#' see [biplot2d()]. Here only the arguments special to +#' see [biplot2d()]. Here only the arguments special to #' `biplotPseudo3d` are outlined. #' #' @param x `repgrid` object. -#' @param dim Dimensions (i.e. principal components) to be used for biplot +#' @param dim Dimensions (i.e. principal components) to be used for biplot #' (default is `c(1,2)`). #' @param map.dim Third dimension (depth) used to map aesthetic attributes to #' (default is `3`). @@ -1547,7 +1627,7 @@ biplot2d <- function(x, dim=c(1,2), map.dim=3, #' will have the same color irrespective of their value on the `map.dim` #' dimension. #' @param e.point.cex Size of the element symbols. Two values can be entered that will -#' represents the lower and upper size of a range of cex the values of `map.dim` +#' represents the lower and upper size of a range of cex the values of `map.dim` #' are mapped onto. The default is `c(.6, 1.2)`. If only one cex value #' is supplied (e.g. `.7`) no mapping occurs and all elements #' will have the same size irrespective of their value on the `map.dim` @@ -1559,14 +1639,14 @@ biplot2d <- function(x, dim=c(1,2), map.dim=3, #' will have the same color irrespective of their value on the `map.dim` #' dimension. #' @param e.label.cex Size of the element labels. Two values can be entered that will -#' represents the lower and upper size of a range of cex the values of `map.dim` +#' represents the lower and upper size of a range of cex the values of `map.dim` #' are mapped onto. The default is `c(.6, .8)`. If only one cex value #' is supplied (e.g. `.7`) no mapping occurs and all element labels #' will have the same size irrespective of their value on the `map.dim` #' dimension. -#' @param e.color.map Value range to determine what range of the color ramp defined in -#' `e.color` will be used for mapping the colors. -#' Default is `c(.4, ,1)`. Usually not important for the user. +#' @param e.color.map Value range to determine what range of the color ramp defined in +#' `e.color` will be used for mapping the colors. +#' Default is `c(.4, ,1)`. Usually not important for the user. #' @param c.point.col Color(s) of the construct symbols. Two values can be entered that will #' create a color ramp. The values of `map.dim` are mapped onto the ramp. #' The default is `c("white", "darkred")`. If only one color color value @@ -1574,7 +1654,7 @@ biplot2d <- function(x, dim=c(1,2), map.dim=3, #' will have the same color irrespective of their value on the `map.dim` #' dimension. #' @param c.point.cex Size of the construct symbols. Two values can be entered that will -#' represents the lower and upper size of a range of cex the values of `map.dim` +#' represents the lower and upper size of a range of cex the values of `map.dim` #' are mapped onto. The default is `c(.6, 1.2)`. If only one cex value #' is supplied (e.g. `.7`) no mapping occurs and all elements #' will have the same size irrespective of their value on the `map.dim` @@ -1586,261 +1666,259 @@ biplot2d <- function(x, dim=c(1,2), map.dim=3, #' will have the same color irrespective of their value on the `map.dim` #' dimension. #' @param c.label.cex Size of the construct labels. Two values can be entered that will -#' represents the lower and upper size of a range of cex the values of `map.dim` +#' represents the lower and upper size of a range of cex the values of `map.dim` #' are mapped onto. The default is `c(.6, .9)`. If only one cex value #' is supplied (e.g. `.7`) no mapping occurs and all construct labels #' will have the same size irrespective of their value on the `map.dim` #' dimension. -#' @param c.color.map Value range to determine what range of the color ramp defined in +#' @param c.color.map Value range to determine what range of the color ramp defined in #' `c.color` will be used for mapping. Default is `c(.4, ,1)`. #' Usually not important for the user. #' @param ... Additional parameters passed to [biplot2d()]. -#' +#' #' @export #' @seealso #' - Unsophisticated biplot: [biplotSimple()]; -#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; -#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; -#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; +#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; +#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; +#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; #' - Function to set view in 3D: [home()] #' #' @examples \dontrun{ -#' # biplot with 3D impression -#' biplotPseudo3d(boeker) -#' # Slater's biplot with 3D impression -#' biplotPseudo3d(boeker, g=1, h=1, center=1) -#' -#' # show 2nd and 3rd dim. and map 4th -#' biplotPseudo3d(boeker, dim=2:3, map.dim=4) -#' -#' # change elem. colors -#' biplotPseudo3d(boeker, e.color=c("white", "darkgreen")) -#' # change con. colors -#' biplotPseudo3d(boeker, c.color=c("white", "darkgreen")) -#' # change color mapping range -#' biplotPseudo3d(boeker, c.colors.map=c(0, 1)) -#' -#' # set uniform con. text size -#' biplotPseudo3d(boeker, c.cex=1) -#' # change text size mapping range -#' biplotPseudo3d(boeker, c.cex=c(.4, 1.2)) +#' # biplot with 3D impression +#' biplotPseudo3d(boeker) +#' # Slater's biplot with 3D impression +#' biplotPseudo3d(boeker, g = 1, h = 1, center = 1) +#' +#' # show 2nd and 3rd dim. and map 4th +#' biplotPseudo3d(boeker, dim = 2:3, map.dim = 4) +#' +#' # change elem. colors +#' biplotPseudo3d(boeker, e.color = c("white", "darkgreen")) +#' # change con. colors +#' biplotPseudo3d(boeker, c.color = c("white", "darkgreen")) +#' # change color mapping range +#' biplotPseudo3d(boeker, c.colors.map = c(0, 1)) +#' +#' # set uniform con. text size +#' biplotPseudo3d(boeker, c.cex = 1) +#' # change text size mapping range +#' biplotPseudo3d(boeker, c.cex = c(.4, 1.2)) #' } #' -biplotPseudo3d <- function( x, dim=1:2, map.dim=3, - e.point.col=c("white", "black"), - e.point.cex=c(.6, 1.2), - e.label.col=c("white", "black"), - e.label.cex=c(.6, .8), - e.color.map=c(.4, 1), - c.point.col=c("white", "darkred"), - c.point.cex=c(.6, 1.2), - c.label.col=c("white", "darkred"), - c.label.cex=c(.6, .8), - c.color.map=c(.4, 1), - ...) { - biplot2d(x=x, dim=dim, map.dim=map.dim, - e.point.col=e.point.col, - e.point.cex=e.point.cex, - e.label.col=e.label.col, - e.label.cex=e.label.cex, - e.color.map=e.color.map, - c.point.col=c.point.col, - c.point.cex=c.point.cex, - c.label.col=c.label.col, - c.label.cex=c.label.cex, - c.color.map=c.color.map, - ...) +biplotPseudo3d <- function(x, dim = 1:2, map.dim = 3, + e.point.col = c("white", "black"), + e.point.cex = c(.6, 1.2), + e.label.col = c("white", "black"), + e.label.cex = c(.6, .8), + e.color.map = c(.4, 1), + c.point.col = c("white", "darkred"), + c.point.cex = c(.6, 1.2), + c.label.col = c("white", "darkred"), + c.label.cex = c(.6, .8), + c.color.map = c(.4, 1), + ...) { + biplot2d( + x = x, dim = dim, map.dim = map.dim, + e.point.col = e.point.col, + e.point.cex = e.point.cex, + e.label.col = e.label.col, + e.label.cex = e.label.cex, + e.color.map = e.color.map, + c.point.col = c.point.col, + c.point.cex = c.point.cex, + c.label.col = c.label.col, + c.label.cex = c.label.cex, + c.color.map = c.color.map, + ... + ) } - -#' Draws Slater's INGRID biplot in 2D. + +#' Draws Slater's INGRID biplot in 2D. #' -#' The default is to use row centering -#' and no normalization. Note that Slater's biplot is just a +#' The default is to use row centering +#' and no normalization. Note that Slater's biplot is just a #' special case of a biplot #' that can be produced using the [biplot2d()] function with the arguments #' `center=1, g=1, h=1`. The arguments that can be used in this function -#' are the same as in [biplot2d()]. +#' are the same as in [biplot2d()]. #' Here, only the arguments that are set for Slater's biplot are described. #' To see all the parameters that can be changed see [biplot2d()]. #' #' @param x `repgrid` object. -#' @param center Numeric. The type of centering to be performed. -#' 0= no centering, 1= row mean centering (construct), +#' @param center Numeric. The type of centering to be performed. +#' 0= no centering, 1= row mean centering (construct), #' 2= column mean centering (elements), 3= double-centering (construct and element means), #' 4= midpoint centering of rows (constructs). #' Slater's biplot uses `1` (row centering). -#' @param g Power of the singular value matrix assigned to the left singular +#' @param g Power of the singular value matrix assigned to the left singular #' vectors, i.e. the constructs. -#' @param h Power of the singular value matrix assigned to the right singular +#' @param h Power of the singular value matrix assigned to the right singular #' vectors, i.e. the elements. #' @param ... Additional parameters for be passed to [biplot2d()]. #' @export #' @seealso #' - Unsophisticated biplot: [biplotSimple()]; -#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; -#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; -#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; +#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; +#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; +#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; #' - Function to set view in 3D: [home()] #' #' @examples \dontrun{ -#' # See examples in [biplot2d()] as the same arguments -#' # can used for this function. +#' # See examples in [biplot2d()] as the same arguments +#' # can used for this function. #' } #' -biplotSlater2d <- function(x, center=1, g=1, h=1, ...){ - biplot2d(x=x, center=center, g=g, h=h, ...) +biplotSlater2d <- function(x, center = 1, g = 1, h = 1, ...) { + biplot2d(x = x, center = center, g = g, h = h, ...) } #' Draws Slater's biplot in 2D with depth impression (pseudo 3D). #' -#' The default is to use row centering -#' and no normalization. Note that Slater's biplot is just a special -#' case of a biplot that can be produced using the [biplotPseudo3d()] +#' The default is to use row centering +#' and no normalization. Note that Slater's biplot is just a special +#' case of a biplot that can be produced using the [biplotPseudo3d()] #' function with the arguments `center=1, g=1, h=1`. #' Here, only the arguments that are modified for Slater's biplot are described. #' To see all the parameters that can be changed see [biplot2d()] #' and [biplotPseudo3d()]. #' #' @param x `repgrid` object. -#' @param center Numeric. The type of centering to be performed. -#' 0= no centering, 1= row mean centering (construct), +#' @param center Numeric. The type of centering to be performed. +#' 0= no centering, 1= row mean centering (construct), #' 2= column mean centering (elements), 3= double-centering (construct and element means), #' 4= midpoint centering of rows (constructs). #' Slater's biplot uses `1` (row centering). -#' @param g Power of the singular value matrix assigned to the left singular +#' @param g Power of the singular value matrix assigned to the left singular #' vectors, i.e. the constructs. -#' @param h Power of the singular value matrix assigned to the right singular +#' @param h Power of the singular value matrix assigned to the right singular #' vectors, i.e. the elements. #' @param ... Additional parameters for be passed to [biplotPseudo3d()]. #' @export #' @seealso #' - Unsophisticated biplot: [biplotSimple()]; -#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; -#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; -#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; +#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; +#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; +#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; #' - Function to set view in 3D: [home()] #' #' @examples \dontrun{ -#' # See examples in [biplotPseudo3d()] as the same arguments -#' # can used for this function. +#' # See examples in [biplotPseudo3d()] as the same arguments +#' # can used for this function. #' } #' -biplotSlaterPseudo3d <- function(x, center=1, g=1, h=1, ...){ - biplotPseudo3d(x=x, center=center, g=g, h=h, ...) +biplotSlaterPseudo3d <- function(x, center = 1, g = 1, h = 1, ...) { + biplotPseudo3d(x = x, center = center, g = g, h = h, ...) } #' Plot an eigenstructure analysis (ESA) biplot in 2D. -#' +#' #' The ESA is a special type of biplot suggested by Raeithel (e.g. 1998). #' It uses midpoint centering as a default. Note that the eigenstructure analysis -#' is just a special case of a biplot that can also be produced using the -#' [biplot2d()] function with the arguments +#' is just a special case of a biplot that can also be produced using the +#' [biplot2d()] function with the arguments #' `center=4, g=1, h=1`. #' Here, only the arguments that are modified for the ESA biplot are described. #' To see all the parameters that can be changed see [biplot2d()]. #' #' @param x `repgrid` object. -#' @param center Numeric. The type of centering to be performed. -#' 0= no centering, 1= row mean centering (construct), +#' @param center Numeric. The type of centering to be performed. +#' 0= no centering, 1= row mean centering (construct), #' 2= column mean centering (elements), 3= double-centering (construct and element means), #' 4= midpoint centering of rows (constructs). #' Eigenstructure analysis uses midpoint centering (`4`). -#' @param g Power of the singular value matrix assigned to the left singular -#' vectors, i.e. the constructs. Eigenstructure analysis uses +#' @param g Power of the singular value matrix assigned to the left singular +#' vectors, i.e. the constructs. Eigenstructure analysis uses #' `g=1`. -#' @param h Power of the singular value matrix assigned to the right singular -#' vectors, i.e. the elements. Eigenstructure analysis uses +#' @param h Power of the singular value matrix assigned to the right singular +#' vectors, i.e. the elements. Eigenstructure analysis uses #' `h=1`. #' @param ... Additional parameters for be passed to [biplot2d()]. #' -#' @references Raeithel, A. (1998). Kooperative Modellproduktion von Professionellen +#' @references Raeithel, A. (1998). Kooperative Modellproduktion von Professionellen #' und Klienten. Erlaeutert am Beispiel des Repertory Grid. -#' In A. Raeithel (1998). Selbstorganisation, Kooperation, -#' Zeichenprozess. Arbeiten zu einer kulturwissenschaftlichen, -#' anwendungsbezogenen Psychologie (p. 209-254). Opladen: +#' In A. Raeithel (1998). Selbstorganisation, Kooperation, +#' Zeichenprozess. Arbeiten zu einer kulturwissenschaftlichen, +#' anwendungsbezogenen Psychologie (p. 209-254). Opladen: #' Westdeutscher Verlag. #' @export #' #' @seealso #' - Unsophisticated biplot: [biplotSimple()]; -#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; -#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; -#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; +#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; +#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; +#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; #' - Function to set view in 3D: [home()] #' #' @examples \dontrun{ -#' # See examples in [biplot2d()] as the same arguments -#' # can used for this function. +#' # See examples in [biplot2d()] as the same arguments +#' # can used for this function. #' } #' -biplotEsa2d <- function(x, center=4, g=1, h=1, ...){ - biplot2d(x=x, center=center, g=g, h=h, ...) +biplotEsa2d <- function(x, center = 4, g = 1, h = 1, ...) { + biplot2d(x = x, center = center, g = g, h = h, ...) } -#' Plot an eigenstructure analysis (ESA) in 2D grid with 3D -#' impression (pseudo 3D). +#' Plot an eigenstructure analysis (ESA) in 2D grid with 3D +#' impression (pseudo 3D). #' -#' The ESA is +#' The ESA is #' a special type of biplot suggested by Raeithel (e.g. 1998). #' It uses midpoint centering as a default. Note that the eigenstructure analysis -#' is just a special case of a biplot that can also be produced using the -#' [biplot2d()] function with the arguments +#' is just a special case of a biplot that can also be produced using the +#' [biplot2d()] function with the arguments #' `center=4, g=1, h=1`. #' Here, only the arguments that are modified for the ESA biplot are described. #' To see all the parameters that can be changed see [biplot2d()] #' and [biplotPseudo3d()]. #' #' @param x `repgrid` object. -#' @param center Numeric. The type of centering to be performed. -#' 0= no centering, 1= row mean centering (construct), -#' 2= column mean centering (elements), 3= double-centering +#' @param center Numeric. The type of centering to be performed. +#' 0= no centering, 1= row mean centering (construct), +#' 2= column mean centering (elements), 3= double-centering #' (construct and element means), #' 4= midpoint centering of rows (constructs). #' Eigenstructure analysis uses midpoint centering (`4`). -#' @param g Power of the singular value matrix assigned to the left singular -#' vectors, i.e. the constructs. Eigenstructure analysis uses +#' @param g Power of the singular value matrix assigned to the left singular +#' vectors, i.e. the constructs. Eigenstructure analysis uses #' `g=1`. -#' @param h Power of the singular value matrix assigned to the right singular -#' vectors, i.e. the elements. Eigenstructure analysis uses +#' @param h Power of the singular value matrix assigned to the right singular +#' vectors, i.e. the elements. Eigenstructure analysis uses #' `h=1`. #' @param ... Additional parameters for be passed to [biplotPseudo3d()]. #' @export #' @seealso #' - Unsophisticated biplot: [biplotSimple()]; -#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; -#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; -#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; +#' - 2D biplots:[biplot2d()], [biplotEsa2d()], [biplotSlater2d()]; +#' - Pseudo 3D biplots: [biplotPseudo3d()], [biplotEsaPseudo3d()], [biplotSlaterPseudo3d()]; +#' - Interactive 3D biplots: [biplot3d()], [biplotEsa3d()], [biplotSlater3d()]; #' - Function to set view in 3D: [home()] #' #' @examples \dontrun{ -#' # See examples in [biplotPseudo3d()] as the same arguments -#' # can used for this function. +#' # See examples in [biplotPseudo3d()] as the same arguments +#' # can used for this function. #' } #' -biplotEsaPseudo3d <- function(x, center=4, g=1, h=1, ...){ - biplotPseudo3d(x=x, center=center, g=g, h=h, ...) +biplotEsaPseudo3d <- function(x, center = 4, g = 1, h = 1, ...) { + biplotPseudo3d(x = x, center = center, g = g, h = h, ...) } -#////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////// # x <- boeker # x <- calcBiplotCoords(x, g=1, h=1) # x <- prepareBiplotData(x, unity=F) # biplot2d(x) -# +# # biplot2d(x) -#////////////////////////////////////////////////////////// - - - - +# ////////////////////////////////////////////////////////// diff --git a/R/repgrid-ratings.r b/R/repgrid-ratings.r index 56a673b6..b1ef28d2 100644 --- a/R/repgrid-ratings.r +++ b/R/repgrid-ratings.r @@ -1,310 +1,338 @@ -#////////////////////////////////////////////////////////////////////////////// -# -# basic ratings operations -# -#////////////////////////////////////////////////////////////////////////////// - - - -# sets up an array of proper dimension and dim names to be filled with ratings -# if no dimensions are supplied, the proper dimensions are calculated from -# the present number of elements and constructs -initRatingArray <- function(x, nconstructs=NULL, nelements=NULL){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(is.null(nelements)) - nelements <- length(x@elements) - if(is.null(nconstructs)) - nconstructs <- length(x@constructs) - ratingArray <- array(NA, c(nconstructs, nelements, 3)) # ,,1 = coupled ratings; decoupled ratings: ,,2 left pole ,,3 right pole - dimnames(ratingArray) <- list(constructs=NULL, elements=NULL, # set up layers for coupled and decoupled rating - layer=c("coupled", "left pole decoupled", "right pole decoupled")) - x@ratings <- ratingArray - x -} - -#x <- initRatingArray(x, 10, 10) - - -# mat matrix or dataframe -r.setRatings <- function(x, scores=NA, rows=NA, cols=NA, layer=1, ...){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(is.list(scores) & !is.data.frame(scores)) - stop("scores must not be a list.") - if(!(is.matrix(scores) | is.data.frame(scores) | is.vector(scores))) # check if scores is matrix, dataframe or vector - stop("scores must be matrix, dataframe or vector.") - if(is.data.frame(scores)) - scores <- as.matrix(scores) - if(is.na(rows[1]) & length(rows)==1) - rows <- 1:nrow(x@ratings) - if(is.na(cols[1]) & length(cols)==1) - cols <- 1:ncol(x@ratings) - if(max(rows) > nrow(x@ratings)) - stop("number of constructs does not exists.") - if(max(cols) > ncol(x@ratings)){ - stop("number of elements does not exists.") - } - x@ratings[rows, cols, layer] <- - as.vector(matrix(as.vector(scores), ncol=length(x@elements), byrow=TRUE)) - x -} - - # rg <- makeEmptyRepgrid() # make a new repgrid object - # rg <- initRatingArray(rg, 3,5) # initialize rating array - # rg <- setRatings(rg, matrix(1,3,5)) # set whole layer - # rg <- setRatings(rg, 11:12, r=1:2, c=1) # insert a vector - # rg <- setRatings(rg, matrix(1:4,2), r=1:2, c=1:2, l=2) # insert a matrix - # rg <- setRatings(rg, as.data.frame(matrix(1:4,2)), r=1:2, c=2:3, l=3) # insert dataframe - # - - - -# a <- array(NA, c(3, 3, 3)) # ,,1 = coupled ratings; decoupled ratings: ,,2 left pole ,,3 right pole -# dimnames(a) <- list(constructs=NULL, elements=NULL, # set up layers for coupled and decoupled rating -# layer=c("coupled", "left pole decoupled", "right pole decoupled")) -# -# makeNewElementColumn <- function(a){ -# el <- array(NA, c(dim(a)[1], 1, dim(a)[3])) -# el -# } -# a <- abind(a, makeNewElementColumn(a), along=1) -# -# -# makeNewConstructRow <- function(a){ -# con <- array(NA, c(1, dim(a)[2], dim(a)[3])) -# con -# } -# a <- abind(a, makeNewConstructRow(a), along=1) -# -# -# x <- makeEmptyRepgrid() -# makeNewElementColumn <- function(x){ -# a <- x@ratings -# elementColumn <- array(NA, c(dim(a)[1], 1, dim(a)[3])) -# x@ratings <- abind(a, elementColumn, along=2) -# x -# } -# x <- makeNewElementColumn(x) -# -# x <- makeEmptyRepgrid() -# makeNewConstructRow <- function(a){ -# a <- x@ratings -# constructRow <- array(NA, c(1, dim(a)[2], dim(a)[3])) -# x@ratings <- abind(a, constructRow, along=1) -# x -# } -# x <- makeNewConstructRow(x) -# -# -# -# -# makeNewElementColumn <- function(a){ -# el <- array(NA, c(dim(a)[1], 1, dim(a)[3])) -# el -# } -# a <- abind(a, makeNewElementColumn(a), along=2) -# -# pos <- 6 -# index <- insertAt(seq_len(dim(a)[2]), pos) # insert element column at position pos -# a <- abind(a, makeNewElementColumn(a), along=2) # attach new column -# a <- a[, c(index$index.base.new, index$index.insert.new), ] # reorder by pos -# a -#////////////////////////////////////////////////////////////////////////////// - - -r.makeNewElementColumn <- function(x, pos=NA){ - if(is.na(pos[1]&length(pos)==1)) pos <- ncol(x@ratings) + 1 - if(!is.numeric(pos) | pos > ncol(x@ratings) + 1 | pos < 1) - stop("pos must be between 1 number of elements plus one.") - a <- x@ratings - index <- insertAt(seq_len(dim(a)[2]), pos) # insert element column at position pos - elementColumn <- array(NA, c(dim(a)[1], 1, dim(a)[3])) - a <- abind(a, elementColumn, along=2) - x@ratings <- a[, c(index$index.base.new, index$index.insert.new), ,drop = FALSE] # reorder by pos - x -} -#x <- makeEmptyRepgrid() -#x <- r.makeNewElementColumn(x, pos=1) - - - -r_makeNewConstructRow <- function(x, pos=NA){ - if(is.na(pos[1]&length(pos)==1)) pos <- nrow(x@ratings)+1 - if(!is.numeric(pos) | pos > nrow(x@ratings)+1 | pos < 1) - stop("pos must be between 1 number of constructs plus one.") - a <- x@ratings - index <- insertAt(seq_len(dim(a)[1]), pos) # insert construct row at position pos - constructRow <- array(NA, c(1, dim(a)[2], dim(a)[3])) - a <- abind(a, constructRow, along=1) - x@ratings <- a[c(index$index.base.new, index$index.insert.new),, ,drop = FALSE] # reorder by pos - x -} -#x <- makeEmptyRepgrid() -#x <- r_makeNewConstructRow(x) - - -r.addColumns <- function(x, no, position=NA, side="pre"){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(!is.numeric(position) & !(length(position)==1 & is.na(position[1]))) - stop("position must be numeric.") - if(length(position)==1 & is.na(position[1])){ - position <- rep(NA, no) - } - #if(length(unique(position)) != length(position)) # is index unique? - # stop("position values must be unique.") - position[is.na(position)] <- seq_along(position[is.na(position)]) + ncol(x@ratings) - index <- insertAt(seq_len(ncol(x@ratings)), position, side=side) - tmp <- c(index$index.base.new, index$index.insert.new) - if(max(tmp) > length(tmp)) - stop("position has values that will create wholes in the element list.") - for(i in seq_len(no)){ - x <- r.makeNewElementColumn(x) # attach empty columns - } - x <- r.changeRatingsOrder(x, order=orderBy(tmp, seq_len(ncol(x@ratings))), along=2) - x -} - -#r.addColumns(rg, 2, position=c(1,5))@ratings - -r.changeRatingsOrder <- function(x, order=NA, along=1){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(!along %in% 1:2) - stop("along must be 1 for rows(constructs) or 2 for columns (elements).") - if(is.na(order[1]) & length(order)==1){ - if(along==1){ - order <- seq_len(nrow(x@ratings)) # default order along constructs - } else if(along==2){ - order <- seq_len(ncol(x@ratings)) # default order along elements - } - } - if(along==1){ # reorder constructs - if(nrow(x@ratings) != length(order)) - stop("order must have same length as number of rows (constructs) in ratings exist.") - x@ratings <- x@ratings[order,,,drop=FALSE] - } else if(along==2){ # reorder elements - if(ncol(x@ratings) != length(order)) - stop("order must have same length as number of cols (elements) in ratings exist.") - x@ratings <- x@ratings[,order,,drop=FALSE] - } - x -} - -# r.changeRatingsOrder(x, 3:1, a=2) - - - -r.deleteRatingsRow <- function(x, pos=NA){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(is.na(pos[1])){ - return(x); - #break - } - if(any(pos<0 | pos > nrow(x@ratings))) - stop("pos must contains values greater than 1 and equal or less than ratings rows.") - x@ratings <- x@ratings[-pos, , ,drop=FALSE] - x -} - - -r.deleteRatingsColumns <- function(x, pos=NA){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(is.na(pos[1])){ - return(x); - #break - } - if(any(pos<0 | pos > ncol(x@ratings))) - stop("pos must contains values greater than 1 and equal or less than ratings columns.") - x@ratings <- x@ratings[ ,-pos , ,drop=FALSE] - x -} -#r.deleteRatingsColumns(rg) - -# TODO -r.deleteRatings <- function(x, rows=NA, cols=NA){ - if(!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'.") - if(any(rows<0 | rows > nrow(x@ratings))) - stop("pos must contains values greater than 1 and equal or less than ratings rows.") - if(any(rows<0 | rows > nrow(x@ratings))) - stop("pos must contains values greater than 1 and equal or less than ratings rows.") - keeprows <- !(seq_len(nrow(x@ratings)) %in% rows) - keepcols <- !(seq_len(ncol(x@ratings)) %in% cols) - x@ratings <- x@ratings[keeprows, keepcols, ,drop=FALSE] - x -} -#r.deleteRatings(x, 1) -#r.deleteRatings(rg,1) - - - -# r.swopRatingsRows <- function(x, pos1, pos2){ -# if(!inherits(x, "repgrid")) # check if x is repgrid object -# stop("Object x must be of class 'repgrid'.") -# if(any(c(pos1, pos2) < 0) | any(c(pos1, pos2)> nrow(x@ratings))) -# stop("pos1 and pos2 must be bigger than 1 and have number of constructs as a maximum") -# x@ratings[c(pos1, pos2),,] <- x@ratings[c(pos2, pos1),,] -# x -# } -# -# r.swopRatingsColumns <- function(x, pos1, pos2){ -# if(!inherits(x, "repgrid")) # check if x is repgrid object -# stop("Object x must be of class 'repgrid'.") -# if(any(c(pos1, pos2) < 0) | any(c(pos1, pos2)> ncol(x@ratings))) -# stop("pos1 and pos2 must be bigger than 1 and have number of elements as a maximum") -# x@ratings[,c(pos1, pos2),] <- x@ratings[,c(pos2, pos1),] -# x -# } -# -# # str(moveElementTo(x, 1,4)) -# r.moveRatingsRowUpwards <- function(x, pos){ -# if(!inherits(x, "repgrid")) # check if x is repgrid object -# stop("Object x must be of class 'repgrid'.") -# if(pos<=1 | pos > nrow(x@ratings)){ -# return(x) -# } else { -# x <- r.swopRatingsRows(x, pos, pos-1) -# return(x) -# } -# } -# -# r.moveRatingsRowDownwards <- function(x, pos){ -# if(!inherits(x, "repgrid")) # check if x is repgrid object -# stop("Object x must be of class 'repgrid'.") -# if(pos<0 | pos >= nrow(x@ratings)){ -# return(x) -# } else { -# x <- r.swopRatingsRows(x, pos, pos+1) -# return(x) -# } -# } -# -# -# -# # str(moveElementTo(x, 1,4)) -# r.moveRatingsColumnLeftwards <- function(x, pos){ -# if(!inherits(x, "repgrid")) # check if x is repgrid object -# stop("Object x must be of class 'repgrid'.") -# if(pos<=1 | pos > ncol(x@ratings)){ -# return(x) -# } else { -# x <- r.swopRatingsColumns(x, pos, pos-1) -# return(x) -# } -# } -# #moveRatingsColumnLeftwards(x, 2) -# -# r.moveRatingsColumnRightwards <- function(x, pos){ -# if(!inherits(x, "repgrid")) # check if x is repgrid object -# stop("Object x must be of class 'repgrid'.") -# if(pos<0 | pos >= ncol(x@ratings)){ -# return(x) -# } else { -# x <- r.swopRatingsColumns(x, pos, pos+1) -# return(x) -# } -# } +# ////////////////////////////////////////////////////////////////////////////// +# +# basic ratings operations +# +# ////////////////////////////////////////////////////////////////////////////// + + + +# sets up an array of proper dimension and dim names to be filled with ratings +# if no dimensions are supplied, the proper dimensions are calculated from +# the present number of elements and constructs +initRatingArray <- function(x, nconstructs = NULL, nelements = NULL) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (is.null(nelements)) { + nelements <- length(x@elements) + } + if (is.null(nconstructs)) { + nconstructs <- length(x@constructs) + } + ratingArray <- array(NA, c(nconstructs, nelements, 3)) # ,,1 = coupled ratings; decoupled ratings: ,,2 left pole ,,3 right pole + dimnames(ratingArray) <- list( + constructs = NULL, elements = NULL, # set up layers for coupled and decoupled rating + layer = c("coupled", "left pole decoupled", "right pole decoupled") + ) + x@ratings <- ratingArray + x +} + +# x <- initRatingArray(x, 10, 10) + + +# mat matrix or dataframe +r.setRatings <- function(x, scores = NA, rows = NA, cols = NA, layer = 1, ...) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (is.list(scores) & !is.data.frame(scores)) { + stop("scores must not be a list.") + } + if (!(is.matrix(scores) | is.data.frame(scores) | is.vector(scores))) { # check if scores is matrix, dataframe or vector + stop("scores must be matrix, dataframe or vector.") + } + if (is.data.frame(scores)) { + scores <- as.matrix(scores) + } + if (is.na(rows[1]) & length(rows) == 1) { + rows <- 1:nrow(x@ratings) + } + if (is.na(cols[1]) & length(cols) == 1) { + cols <- 1:ncol(x@ratings) + } + if (max(rows) > nrow(x@ratings)) { + stop("number of constructs does not exists.") + } + if (max(cols) > ncol(x@ratings)) { + stop("number of elements does not exists.") + } + x@ratings[rows, cols, layer] <- + as.vector(matrix(as.vector(scores), ncol = length(x@elements), byrow = TRUE)) + x +} + +# rg <- makeEmptyRepgrid() # make a new repgrid object +# rg <- initRatingArray(rg, 3,5) # initialize rating array +# rg <- setRatings(rg, matrix(1,3,5)) # set whole layer +# rg <- setRatings(rg, 11:12, r=1:2, c=1) # insert a vector +# rg <- setRatings(rg, matrix(1:4,2), r=1:2, c=1:2, l=2) # insert a matrix +# rg <- setRatings(rg, as.data.frame(matrix(1:4,2)), r=1:2, c=2:3, l=3) # insert dataframe +# + + + +# a <- array(NA, c(3, 3, 3)) # ,,1 = coupled ratings; decoupled ratings: ,,2 left pole ,,3 right pole +# dimnames(a) <- list(constructs=NULL, elements=NULL, # set up layers for coupled and decoupled rating +# layer=c("coupled", "left pole decoupled", "right pole decoupled")) +# +# makeNewElementColumn <- function(a){ +# el <- array(NA, c(dim(a)[1], 1, dim(a)[3])) +# el +# } +# a <- abind(a, makeNewElementColumn(a), along=1) +# +# +# makeNewConstructRow <- function(a){ +# con <- array(NA, c(1, dim(a)[2], dim(a)[3])) +# con +# } +# a <- abind(a, makeNewConstructRow(a), along=1) +# +# +# x <- makeEmptyRepgrid() +# makeNewElementColumn <- function(x){ +# a <- x@ratings +# elementColumn <- array(NA, c(dim(a)[1], 1, dim(a)[3])) +# x@ratings <- abind(a, elementColumn, along=2) +# x +# } +# x <- makeNewElementColumn(x) +# +# x <- makeEmptyRepgrid() +# makeNewConstructRow <- function(a){ +# a <- x@ratings +# constructRow <- array(NA, c(1, dim(a)[2], dim(a)[3])) +# x@ratings <- abind(a, constructRow, along=1) +# x +# } +# x <- makeNewConstructRow(x) +# +# +# +# +# makeNewElementColumn <- function(a){ +# el <- array(NA, c(dim(a)[1], 1, dim(a)[3])) +# el +# } +# a <- abind(a, makeNewElementColumn(a), along=2) +# +# pos <- 6 +# index <- insertAt(seq_len(dim(a)[2]), pos) # insert element column at position pos +# a <- abind(a, makeNewElementColumn(a), along=2) # attach new column +# a <- a[, c(index$index.base.new, index$index.insert.new), ] # reorder by pos +# a +# ////////////////////////////////////////////////////////////////////////////// + + +r.makeNewElementColumn <- function(x, pos = NA) { + if (is.na(pos[1] & length(pos) == 1)) pos <- ncol(x@ratings) + 1 + if (!is.numeric(pos) | pos > ncol(x@ratings) + 1 | pos < 1) { + stop("pos must be between 1 number of elements plus one.") + } + a <- x@ratings + index <- insertAt(seq_len(dim(a)[2]), pos) # insert element column at position pos + elementColumn <- array(NA, c(dim(a)[1], 1, dim(a)[3])) + a <- abind(a, elementColumn, along = 2) + x@ratings <- a[, c(index$index.base.new, index$index.insert.new), , drop = FALSE] # reorder by pos + x +} +# x <- makeEmptyRepgrid() +# x <- r.makeNewElementColumn(x, pos=1) + + + +r_makeNewConstructRow <- function(x, pos = NA) { + if (is.na(pos[1] & length(pos) == 1)) pos <- nrow(x@ratings) + 1 + if (!is.numeric(pos) | pos > nrow(x@ratings) + 1 | pos < 1) { + stop("pos must be between 1 number of constructs plus one.") + } + a <- x@ratings + index <- insertAt(seq_len(dim(a)[1]), pos) # insert construct row at position pos + constructRow <- array(NA, c(1, dim(a)[2], dim(a)[3])) + a <- abind(a, constructRow, along = 1) + x@ratings <- a[c(index$index.base.new, index$index.insert.new), , , drop = FALSE] # reorder by pos + x +} +# x <- makeEmptyRepgrid() +# x <- r_makeNewConstructRow(x) + + +r.addColumns <- function(x, no, position = NA, side = "pre") { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (!is.numeric(position) & !(length(position) == 1 & is.na(position[1]))) { + stop("position must be numeric.") + } + if (length(position) == 1 & is.na(position[1])) { + position <- rep(NA, no) + } + # if(length(unique(position)) != length(position)) # is index unique? + # stop("position values must be unique.") + position[is.na(position)] <- seq_along(position[is.na(position)]) + ncol(x@ratings) + index <- insertAt(seq_len(ncol(x@ratings)), position, side = side) + tmp <- c(index$index.base.new, index$index.insert.new) + if (max(tmp) > length(tmp)) { + stop("position has values that will create wholes in the element list.") + } + for (i in seq_len(no)) { + x <- r.makeNewElementColumn(x) # attach empty columns + } + x <- r.changeRatingsOrder(x, order = orderBy(tmp, seq_len(ncol(x@ratings))), along = 2) + x +} + +# r.addColumns(rg, 2, position=c(1,5))@ratings + +r.changeRatingsOrder <- function(x, order = NA, along = 1) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (!along %in% 1:2) { + stop("along must be 1 for rows(constructs) or 2 for columns (elements).") + } + if (is.na(order[1]) & length(order) == 1) { + if (along == 1) { + order <- seq_len(nrow(x@ratings)) # default order along constructs + } else if (along == 2) { + order <- seq_len(ncol(x@ratings)) # default order along elements + } + } + if (along == 1) { # reorder constructs + if (nrow(x@ratings) != length(order)) { + stop("order must have same length as number of rows (constructs) in ratings exist.") + } + x@ratings <- x@ratings[order, , , drop = FALSE] + } else if (along == 2) { # reorder elements + if (ncol(x@ratings) != length(order)) { + stop("order must have same length as number of cols (elements) in ratings exist.") + } + x@ratings <- x@ratings[, order, , drop = FALSE] + } + x +} + +# r.changeRatingsOrder(x, 3:1, a=2) + + + +r.deleteRatingsRow <- function(x, pos = NA) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (is.na(pos[1])) { + return(x) + # break + } + if (any(pos < 0 | pos > nrow(x@ratings))) { + stop("pos must contains values greater than 1 and equal or less than ratings rows.") + } + x@ratings <- x@ratings[-pos, , , drop = FALSE] + x +} + + +r.deleteRatingsColumns <- function(x, pos = NA) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (is.na(pos[1])) { + return(x) + # break + } + if (any(pos < 0 | pos > ncol(x@ratings))) { + stop("pos must contains values greater than 1 and equal or less than ratings columns.") + } + x@ratings <- x@ratings[, -pos, , drop = FALSE] + x +} +# r.deleteRatingsColumns(rg) + +# TODO +r.deleteRatings <- function(x, rows = NA, cols = NA) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'.") + } + if (any(rows < 0 | rows > nrow(x@ratings))) { + stop("pos must contains values greater than 1 and equal or less than ratings rows.") + } + if (any(rows < 0 | rows > nrow(x@ratings))) { + stop("pos must contains values greater than 1 and equal or less than ratings rows.") + } + keeprows <- !(seq_len(nrow(x@ratings)) %in% rows) + keepcols <- !(seq_len(ncol(x@ratings)) %in% cols) + x@ratings <- x@ratings[keeprows, keepcols, , drop = FALSE] + x +} +# r.deleteRatings(x, 1) +# r.deleteRatings(rg,1) + + + +# r.swopRatingsRows <- function(x, pos1, pos2){ +# if(!inherits(x, "repgrid")) # check if x is repgrid object +# stop("Object x must be of class 'repgrid'.") +# if(any(c(pos1, pos2) < 0) | any(c(pos1, pos2)> nrow(x@ratings))) +# stop("pos1 and pos2 must be bigger than 1 and have number of constructs as a maximum") +# x@ratings[c(pos1, pos2),,] <- x@ratings[c(pos2, pos1),,] +# x +# } +# +# r.swopRatingsColumns <- function(x, pos1, pos2){ +# if(!inherits(x, "repgrid")) # check if x is repgrid object +# stop("Object x must be of class 'repgrid'.") +# if(any(c(pos1, pos2) < 0) | any(c(pos1, pos2)> ncol(x@ratings))) +# stop("pos1 and pos2 must be bigger than 1 and have number of elements as a maximum") +# x@ratings[,c(pos1, pos2),] <- x@ratings[,c(pos2, pos1),] +# x +# } +# +# # str(moveElementTo(x, 1,4)) +# r.moveRatingsRowUpwards <- function(x, pos){ +# if(!inherits(x, "repgrid")) # check if x is repgrid object +# stop("Object x must be of class 'repgrid'.") +# if(pos<=1 | pos > nrow(x@ratings)){ +# return(x) +# } else { +# x <- r.swopRatingsRows(x, pos, pos-1) +# return(x) +# } +# } +# +# r.moveRatingsRowDownwards <- function(x, pos){ +# if(!inherits(x, "repgrid")) # check if x is repgrid object +# stop("Object x must be of class 'repgrid'.") +# if(pos<0 | pos >= nrow(x@ratings)){ +# return(x) +# } else { +# x <- r.swopRatingsRows(x, pos, pos+1) +# return(x) +# } +# } +# +# +# +# # str(moveElementTo(x, 1,4)) +# r.moveRatingsColumnLeftwards <- function(x, pos){ +# if(!inherits(x, "repgrid")) # check if x is repgrid object +# stop("Object x must be of class 'repgrid'.") +# if(pos<=1 | pos > ncol(x@ratings)){ +# return(x) +# } else { +# x <- r.swopRatingsColumns(x, pos, pos-1) +# return(x) +# } +# } +# #moveRatingsColumnLeftwards(x, 2) +# +# r.moveRatingsColumnRightwards <- function(x, pos){ +# if(!inherits(x, "repgrid")) # check if x is repgrid object +# stop("Object x must be of class 'repgrid'.") +# if(pos<0 | pos >= ncol(x@ratings)){ +# return(x) +# } else { +# x <- r.swopRatingsColumns(x, pos, pos+1) +# return(x) +# } +# } diff --git a/R/repgrid.r b/R/repgrid.r index 1560de8c..057e1f81 100644 --- a/R/repgrid.r +++ b/R/repgrid.r @@ -1,84 +1,82 @@ -#////////////////////////////////////////////////////////////////////////////// -# -# DEFINITION OF THE STRUCTURE OF REPGRID CLASS -# -#////////////////////////////////////////////////////////////////////////////// - -# In this file the repgrid classes are defined. -# Design note: the objects will be defined using S4 classes. - -### NOTE: -# in the current approach (e.g. function implementation, use and definition, -# especially in the arguments) that you might find restricting or tedious as -# an advanced R user programmer. The main user group will be newcomers to R -# though. Thus, implementation tries to provide maximal ease of use without -# requiring deeper R knowledge. Advanced R users will easily find their way -# around those limitations. - - -# Definition of repgrid class -# -# @slot meta A list to store meta data for the repertory grid. -# This includes name of interviewer and interviewee, -# data, miscellaneous notes etc. -# @slot scale The rating scale used (minimum, maximum ec.). -# @slot elements The elements of the grid including meta information like -# "ideal" etc. -# @slot constructs The constructs of the grid, containing meta information -# like pole preference or different ladders. -# @slot elicitation Information about the elicitation procedure used. -# @slot ratings The ratings. -# @slot coupled If the grid is coupled (standard) or decoupled (sci:vesco) -# format, allowing bent constructs. -# @slot calcs Results from calculations. -# @slot plotdata Information for plotting the grid. -# -# @export -# -setClass( "repgrid", - representation( meta = "list", - scale = "list", - coupled = "logical", - elements = "list", - constructs = "list", - elicitation = "list", - ratings = "array", - calcs = "list", - plotdata = "data.frame")) - - -#' Constructor for repgrid class -#' -#' @return `repgrid` object -#' @export -#' @keywords internal -makeEmptyRepgrid <- function(){ - x <- new("repgrid") - x@ratings <- array(NA, c(0, 0, 3)) # ,,1 = coupled ratings; decoupled ratings: ,,2 left pole ,,3 right pole - dimnames(x@ratings) <- list(constructs=NULL, elements=NULL, # set up layers for coupled and decoupled rating - layer=c("coupled", "left pole decoupled", "right pole decoupled")) - x -} - - -# #' Show method for testClass -# #' @param testClass object -# setMethod("show", "repgrid", function(object){ -# cat("object of class 'repgrid'") -# }) - -# #' Show method for repgrid -# #' @param repgrid object -# setMethod("show", signature= "repgrid", function(object){ -# x <- object -# showMeta(x) -# showScale(x) #print scale info -# }) - - - - - - - - +# ////////////////////////////////////////////////////////////////////////////// +# +# DEFINITION OF THE STRUCTURE OF REPGRID CLASS +# +# ////////////////////////////////////////////////////////////////////////////// + +# In this file the repgrid classes are defined. +# Design note: the objects will be defined using S4 classes. + +### NOTE: +# in the current approach (e.g. function implementation, use and definition, +# especially in the arguments) that you might find restricting or tedious as +# an advanced R user programmer. The main user group will be newcomers to R +# though. Thus, implementation tries to provide maximal ease of use without +# requiring deeper R knowledge. Advanced R users will easily find their way +# around those limitations. + + +# Definition of repgrid class +# +# @slot meta A list to store meta data for the repertory grid. +# This includes name of interviewer and interviewee, +# data, miscellaneous notes etc. +# @slot scale The rating scale used (minimum, maximum ec.). +# @slot elements The elements of the grid including meta information like +# "ideal" etc. +# @slot constructs The constructs of the grid, containing meta information +# like pole preference or different ladders. +# @slot elicitation Information about the elicitation procedure used. +# @slot ratings The ratings. +# @slot coupled If the grid is coupled (standard) or decoupled (sci:vesco) +# format, allowing bent constructs. +# @slot calcs Results from calculations. +# @slot plotdata Information for plotting the grid. +# +# @export +# +setClass( + "repgrid", + representation( + meta = "list", + scale = "list", + coupled = "logical", + elements = "list", + constructs = "list", + elicitation = "list", + ratings = "array", + calcs = "list", + plotdata = "data.frame" + ) +) + + +#' Constructor for repgrid class +#' +#' @return `repgrid` object +#' @export +#' @keywords internal +makeEmptyRepgrid <- function() { + x <- new("repgrid") + x@ratings <- array(NA, c(0, 0, 3)) # ,,1 = coupled ratings; decoupled ratings: ,,2 left pole ,,3 right pole + dimnames(x@ratings) <- list( + constructs = NULL, elements = NULL, # set up layers for coupled and decoupled rating + layer = c("coupled", "left pole decoupled", "right pole decoupled") + ) + x +} + + +# #' Show method for testClass +# #' @param testClass object +# setMethod("show", "repgrid", function(object){ +# cat("object of class 'repgrid'") +# }) + +# #' Show method for repgrid +# #' @param repgrid object +# setMethod("show", signature= "repgrid", function(object){ +# x <- object +# showMeta(x) +# showScale(x) #print scale info +# }) diff --git a/R/resampling.R b/R/resampling.R index f92907e1..7970a24e 100644 --- a/R/resampling.R +++ b/R/resampling.R @@ -1,51 +1,50 @@ - -## Resampling of grid - - -#' Resample constructs -#' -#' The goal of resampling is to build variations of a single grid. -#' Two variants are implemented: The first is the *leave-n-out* approach which -#' builds all possible grids when dropping n constructs. The second is a -#' *bootstrap* approach, randomly drawing n constructs from the grid. -#' @param x A repgrid object. -#' @param n Number of constructs to drop or to sample in each generated grid. -#' @return List of grids. -#' @export -#' @rdname resampling -#' @example inst/examples/example-resampling.R -#' -grids_leave_n_out <- function(x, n = 0) -{ - if (!inherits(x, "repgrid")) - stop("Object must be of class 'repgrid'") - nc <- getNoOfConstructs(x) # size construct system - prop <- n / nc # proportion left out - if (prop > .4) - warning("Be aware that you leave more than 40% or more of the constructs", call. = FALSE) - n.subset <- nc - n - l <- combn(seq_len(nc), n.subset, simplify = F) # list of subset indexes - l <- lapply(l, function(i, x) x[i, ], x = x) - as.gridlist(l) -} - - -#' @param reps Number of grids to generate. -#' @param replace Resample constructs with replacement? -#' @export -#' @rdname resampling -#' -grids_bootstrap <- function(x, n = nrow(x), reps = 100, replace = TRUE) -{ - if (!inherits(x, "repgrid")) - stop("Object must be of class 'repgrid'") - nc <- getNoOfConstructs(x) # size construct system - prop <- n / nc # proportion to sample - if (prop < .6) - warning("Be aware that you resample less than 60% of the constructs", call. = FALSE) - l_i <- replicate(reps, sample(seq_len(nc), n, replace = replace), simplify = FALSE) - l <- lapply(l_i, function(i, x) x[i, ], x = x) - as.gridlist(l) -} - - +## Resampling of grid + + +#' Resample constructs +#' +#' The goal of resampling is to build variations of a single grid. +#' Two variants are implemented: The first is the *leave-n-out* approach which +#' builds all possible grids when dropping n constructs. The second is a +#' *bootstrap* approach, randomly drawing n constructs from the grid. +#' @param x A repgrid object. +#' @param n Number of constructs to drop or to sample in each generated grid. +#' @return List of grids. +#' @export +#' @rdname resampling +#' @example inst/examples/example-resampling.R +#' +grids_leave_n_out <- function(x, n = 0) { + if (!inherits(x, "repgrid")) { + stop("Object must be of class 'repgrid'") + } + nc <- getNoOfConstructs(x) # size construct system + prop <- n / nc # proportion left out + if (prop > .4) { + warning("Be aware that you leave more than 40% or more of the constructs", call. = FALSE) + } + n.subset <- nc - n + l <- combn(seq_len(nc), n.subset, simplify = F) # list of subset indexes + l <- lapply(l, function(i, x) x[i, ], x = x) + as.gridlist(l) +} + + +#' @param reps Number of grids to generate. +#' @param replace Resample constructs with replacement? +#' @export +#' @rdname resampling +#' +grids_bootstrap <- function(x, n = nrow(x), reps = 100, replace = TRUE) { + if (!inherits(x, "repgrid")) { + stop("Object must be of class 'repgrid'") + } + nc <- getNoOfConstructs(x) # size construct system + prop <- n / nc # proportion to sample + if (prop < .6) { + warning("Be aware that you resample less than 60% of the constructs", call. = FALSE) + } + l_i <- replicate(reps, sample(seq_len(nc), n, replace = replace), simplify = FALSE) + l <- lapply(l_i, function(i, x) x[i, ], x = x) + as.gridlist(l) +} diff --git a/R/rgl-3d.r b/R/rgl-3d.r index 5f6405af..ccb96470 100644 --- a/R/rgl-3d.r +++ b/R/rgl-3d.r @@ -1,664 +1,683 @@ -#' Draw standard axes in the origin in an rgl plot. -#' -#' @param max.dim maximum length of axis. -#' @param lwd line width. -#' @param a.cex cex for axis labels. -#' @param a.col axis color. -#' @param a.radius radius of spheres at the end points of the axes. -#' @param labels logical. whether to draw axis labels. -#' @param spheres logical. whether to draw axis spheres at the end points. -#' @param ... not evaluated. -#' @export -#' @keywords internal -rglDrawStandardAxes <- function(max.dim=1, lwd=1, a.cex=1.1, a.col="black", - a.radius=.05, labels=TRUE, spheres=FALSE, ...){ - lines3d(c(0, max.dim), c(0,0), c(0,0), lwd=lwd, col=a.col) - lines3d(c(0,0), c(0, max.dim), c(0,0), lwd=lwd, col=a.col) - lines3d(c(0,0), c(0,0), c(0, max.dim), lwd=lwd, col=a.col) - if (labels){ - text3d(max.dim, 0, 0, "X", cex=a.cex, adj=c(1,1), col=a.col) - text3d(0, max.dim, 0, "Y", cex=a.cex, adj=c(1,1), col=a.col) - text3d(0, 0, max.dim, "Z", cex=a.cex, adj=c(1,1), col=a.col) - } - if (spheres){ - spheres3d(max.dim, 0, 0, radius=a.radius, col=a.col) - spheres3d(0, max.dim, 0, radius=a.radius, col=a.col) - spheres3d(0, 0, max.dim, radius=a.radius, col=a.col) - } -} -# open3d() -# points3d(rnorm(1000), rnorm(1000), rnorm(1000), color=heat.colors(1000)) -# rglDrawStandardAxes(3) - - -#' Draw standard ellipses in the origin in an rgl plot. -#' -#' @param max.dim soon -#' @param lwd soon -#' @param col soon -#' @export -#' @keywords internal -#' -rglDrawStandardEllipses <- function(max.dim=1, lwd=1, col="black"){ - x <- seq(0, 2*pi, len=361) - x <- data.frame(sin(x), cos(x)) * max.dim - lines3d(x[,1], x[,2], 0, col=col, lwd=lwd) - lines3d(x[,1], 0, x[,2], col=col, lwd=lwd) - lines3d(0, x[,1], x[,2], col=col, lwd=lwd) -} - - - -rglDrawElementPoints <- function(coords, dim=1:3, e.radius=.1, e.sphere.col="black", ...){ - coords <- coords[ ,dim] - spheres3d(coords[,1], coords[,2], coords[,3], - radius=e.radius, color=e.sphere.col, aspect=F) -} - - -rglDrawElementLabels <- function(coords, labels=FALSE, dim=1:3, e.radius=.1, e.cex=.6, e.text.col="black", ...){ - coords <- coords[ ,dim] - if (!identical(labels, FALSE)){ - coords.text <- coords - e.radius/2 # offset text for elements - texts3d(x= coords.text[,1], - y= coords.text[,2], - z= coords.text[,3], - texts=labels, adj=c(1,1), cex=e.cex, col=e.text.col, aspect =F ) - } -} - - -#' draw constructs in rgl -#' -#' @param coords coordinates for construct points. -#' @param dim dimensions of coordinates to use. -#' @param c.radius radius of construct spheres. -#' @param c.sphere.col color of construct spheres. -#' @param ... not evaluated. -#' @export -#' @keywords internal -#' -rglDrawConstructPoints <- function(coords, dim=1:3, c.radius=.02, c.sphere.col=grey(.4), - ...){ - coords <- coords[ ,dim] - coords[is.na(coords)] <- 0 # replace NAs by zero, so Na can be entered as dim for 2d projection - spheres3d(coords[, dim], radius=c.radius, color=c.sphere.col) -} - -#' draw constructs in rgl -#' -#' @param coords coordinates for constructs labels. -#' @param labels labels for constructs. -#' @param dim dimensions of coordinates to use. -#' @param c.cex cex for construct text. -#' @param c.text.col color for construct text. -#' @param ... not evaluated. -#' @export -#' @keywords internal -#' -rglDrawConstructLabels <- function(coords, labels=FALSE, dim=1:3, - c.cex=.6, c.text.col=grey(.4), ...){ - coords <- coords[ ,dim] - coords[is.na(coords)] <- 0 # replace NAs by zero, so Na can be entered as dim for 2d projection - if (!identical(labels, FALSE)){ - texts3d(coords, texts=labels, adj=c(.5,.5), - cex=c.cex, col=c.text.col, aspect=F) - } -} - - -#' biplot3dBase2 is the workhorse to draw a grid in rgl (3D device). -#' -#' @param x `repgrid` object. -#' @param dim Dimensions to display. -#' @param labels.e Logical. whether element labels are displayed. -#' @param labels.c Logical. whether construct labels are displayed. -#' @param lines.c Numeric. The way lines are drawn through the construct vectors. -#' `0 =` no lines, `1 =` lines from constructs to outer frame, -#' `2 =` lines from the center to outer frame. -#' @param lef Construct lines extension factor. -#' @param alpha.sphere Numeric. alpha blending of the surrounding sphere (default`".05"`). -#' @param col.sphere Color of surrounding sphere (default`"black"`). -#' @param ext.sphere Extension factor for sphere -#' @param col.frame Color of the surrounding frame. -#' @param zoom Not yet used. Scaling factor for all vectors. Can be used to zoom -#' the plot in and out (default `1`). -#' @param draw.xyz.axes Draw standard XYZ axes. -#' @param ... Parameters to be passed on. -#' @keywords internal -#' @export -#' -biplot3dBase2 <- function(x, dim=1:3, labels.e=TRUE, labels.c=TRUE, lines.c=1, - lef=1.1, frame=1, col.frame=grey(.6), - col.sphere ="black", alpha.sphere=.05, zoom=1, - draw.xyz.axes = TRUE, -# c.points.show=TRUE, -# c.labels.show=TRUE, -# e.points.show=TRUE, -# e.labels.show=TRUE, - ...) -{ - x <- calcBiplotCoords(x, ...) - x <- prepareBiplotData(x, ...) - - showpoint <- showlabel <- type <- NULL # to prevent 'R CMD check' from noting a missing binding - # as the variables are provided in object x as default - open3d() # open rgl device - par3d(params=list( - windowRect=c(100,100,600,600))) # enlarge and position 3d device - view3d(theta = 0, phi = 0, zoom=.6) # change 3d view angle - bg3d(color="white") # set background color - - # select spheres to draw and labels to show - # select which elements to show - if (identical(labels.e, TRUE)) - labels.e <- elements(x) - if (identical(labels.c, TRUE)){ - labels.l <- constructs(x)$leftpole - labels.r <- constructs(x)$rightpole - } else { - labels.r <- FALSE - labels.l <- FALSE - } - - X <- x@calcs$biplot$X # pre-transformed (centered etc.) grid matrix - Eu <- x@calcs$biplot$e.unity # element coordinates scaled/unified - Cu <- x@calcs$biplot$c.unity # construct coordinates scaled/unified - - pdat <- x@plotdata # plotdata prepared by prepareBiplotData() - - mval <- max(abs(rbind(Eu[, dim], Cu[ ,dim])), # get maximum value of construct and element coordinates - na.rm=TRUE) - - #Eu <- Eu * zoom - #Cu <- Cu * zoom - - # prolongation of construct vector to outer side - Cu.norm <- apply(Cu[, dim]^2, 1, sum, na.rm=TRUE)^.5 - Cup <- Cu[, dim] / Cu.norm * (lef * mval) - - # plot element spheres - es.p <- subset(pdat, type=="e" & showpoint==T) - rglDrawElementPoints(es.p[c("x", "y", "z")], e.radius=mval/50, ...) - # labels for elements - es.l <- subset(pdat, type=="e" & showlabel==T & showpoint==T) - rglDrawElementLabels(es.l[c("x", "y", "z")], labels=es.l$label, e.radius=mval/50, ...) - - standardizeCoords <- function(x, dim=1:3){ - x.norm <- apply(x[, dim]^2, 1, sum, na.rm=TRUE)^.5 - xsc <- x[, dim] / x.norm * (lef * mval) - xsc - } - - # make construct spheres - cs.p <- subset(pdat, type %in% c("cl", "cr") & showpoint==T) - cs.p.xyz <- cs.p[c("x", "y", "z")] - # labels for constructs - cs.l <- subset(pdat, type %in% c("cl", "cr") & showlabel==T) - cl.l.xyz <- cs.l[c("x", "y", "z")] - cl.l.xyz.outer <- standardizeCoords(cs.l[c("x", "y", "z")]) - - if (lines.c == 0){ # no construct lines labels at cons pos - rglDrawConstructLabels(cl.l.xyz, labels=cs.l$label, ...) - if (draw.xyz.axes) rglDrawStandardAxes(mval, spheres=F) - #rglDrawConstructLabels(Cu[, dim], labels=labels.r, ...) - #rglDrawConstructLabels(-Cu[, dim], labels=labels.l, ...) - } else if (lines.c == 1){ # construct lines from cons pos to outside - segments3d(interleave(cl.l.xyz, cl.l.xyz.outer), col="grey") - rglDrawConstructLabels(cl.l.xyz.outer, labels=cs.l$label, ...) - if (draw.xyz.axes) rglDrawStandardAxes(lef * mval, a.col="black") - #segments3d(interleave(-Cu[, dim], -Cup), col="grey") # Cu and Cup from older implementation without use if x@plotdata - #rglDrawConstructLabels(Cup, labels=labels.r, ...) - #rglDrawConstructLabels(-Cup, labels=labels.l, ...) - } else if (lines.c == 2){ # construct lines from center to outside - nm <- matrix(0, ncol=3, nrow=nrow(cl.l.xyz.outer)) - segments3d(interleave(nm, as.matrix(cl.l.xyz.outer)), col="grey") - rglDrawConstructLabels(cl.l.xyz.outer, labels=cs.l$label, ...) - if (draw.xyz.axes) rglDrawStandardAxes(lef * mval, a.col="black") - } else { - stop("'lines.c' can only take numeric values from 0 to 2") - } - rglDrawConstructPoints(cs.p.xyz, c.radius=mval/200, ...) - #rglDrawConstructPoints(-Cu[, dim], c.radius=mval/200, ...) - #rglDrawStandardEllipses(max.dim) - - # trick to make user coordinate system's origin the center of rotation - mval <- max(abs(par3d()$bbox)) # get max value in x,y,z - ps <- interleave(mval*diag(3), -mval*(diag(3))) - spheres3d(ps, radius=0) # draw invisible spheres at the extremes - - # select type of frame ariound the whole plot - # 0=none, 1= simple box, 2= box with grid, 3=sphere. - if (frame == 1){ - # make box around device - ss <- matrix(c( mval, mval, mval, # top - -mval, mval, mval, - -mval, mval, mval, - -mval, -mval, mval, - -mval, -mval, mval, - mval, -mval, mval, - mval, -mval, mval, - mval, mval, mval, - mval, mval, -mval, # bottom - -mval, mval, -mval, - -mval, mval, -mval, - -mval, -mval, -mval, - -mval, -mval, -mval, - mval, -mval, -mval, - mval, -mval, -mval, - mval, mval, -mval, - mval, mval, mval, # sides - mval, mval, -mval, - -mval, mval, mval, - -mval, mval, -mval, - -mval, -mval, mval, - -mval, -mval, -mval, - mval, -mval, mval, - mval, -mval, -mval), ncol=3, byrow=T) - segments3d(ss, col=col.frame) - } else if (frame == 2){ - grid3d(c("x+","x-", "y+", "y-", "z+", "z-")) - } else if (frame == 3){ - # sphere for easier 3D impression if prompted - spheres3d(0, 0, 0, radius=mval, color=col.sphere, - alpha=alpha.sphere, aspect=F, front="lines", back="lines") - } -} - - - -#' Draw grid in rgl (3D device). -#' -#' The 3D biplot opens an interactive -#' 3D device that can be rotated and zoomed using the mouse. -#' A 3D device facilitates the exploration of grid data as -#' significant proportions of the sum-of-squares are often -#' represented beyond the first two dimensions. Also, in a lot of -#' cases it may be of interest to explore the grid space from -#' a certain angle, e.g. to gain an optimal view onto the set -#' of elements under investigation (e.g. Raeithel, 1998). -#' -#' @param x `repgrid` object. -#' @param dim Dimensions to display. -#' @param labels.e Logical. whether element labels are displayed. -#' @param labels.c Logical. whether construct labels are displayed. -#' @param lines.c Numeric. The way lines are drawn through the construct vectors. -#' `0 =` no lines, `1 =` lines from constructs to outer frame, -#' `2 =` lines from the center to outer frame. -#' @param lef Construct lines extension factor -#' -#' @param center Numeric. The type of centering to be performed. -#' 0= no centering, 1= row mean centering (construct), -#' 2= column mean centering (elements), 3= double-centering (construct and element means), -#' 4= midpoint centering of rows (constructs). -#' Default is `1` (row centering). -#' -#' @param normalize A numeric value indicating along what direction (rows, columns) -#' to normalize by standard deviations. `0 = none, 1= rows, 2 = columns` -#' (default is `0`). -#' @param g Power of the singular value matrix assigned to the left singular -#' vectors, i.e. the constructs. -#' @param h Power of the singular value matrix assigned to the right singular -#' vectors, i.e. the elements. -#' @param col.active Columns (elements) that are no supplementary points, i.e. they are used -#' in the SVD to find principal components. default is to use all elements. -#' @param col.passive Columns (elements) that are supplementary points, i.e. they are NOT used -#' in the SVD but projected into the component space afterwards. They do not -#' determine the solution. Default is `NA`, i.e. no elements are set -#' supplementary. -#' -#' @param c.sphere.col Color of construct spheres. -#' @param c.cex Size of construct text. -#' @param c.text.col Color for construct text. -#' -#' @param e.sphere.col Color of elements. -#' @param e.cex Size of element labels. -#' @param e.text.col Color of element labels. -#' -#' @param alpha.sphere Numeric. alpha blending of the surrounding sphere (default`".05"`). -#' @param col.sphere Color of surrounding sphere (default`"black"`). -#' -#' @param unity Scale elements and constructs coordinates to unit scale (maximum of 1) -#' so they are printed more neatly (default `TRUE`). -#' @param unity3d To come. -#' @param scale.e Scaling factor for element vectors. Will cause element points to move a bit more -#' to the center (but only if `unity` or `unity3d` is `TRUE`). -#' This argument is for visual appeal only. -#' @param zoom Not yet used. Scaling factor for all vectors. Can be used to zoom -#' the plot in and out (default `1`). -#' @param ... Parameters to be passed on. -#' @export -#' @seealso Unsophisticated biplot: [biplotSimple()]; \cr -#' 2D biplots: -#' [biplot2d()], -#' [biplotEsa2d()], -#' [biplotSlater2d()];\cr -#' Pseudo 3D biplots: -#' [biplotPseudo3d()], -#' [biplotEsaPseudo3d()], -#' [biplotSlaterPseudo3d()];\cr -#' Interactive 3D biplots: -#' [biplot3d()], -#' [biplotEsa3d()], -#' [biplotSlater3d()];\cr -#' Function to set view in 3D: -#' [home()]. -#' -#' @references Raeithel, A. (1998). Kooperative Modellproduktion von -#' Professionellen und Klienten - erlauetert am Beispiel des -#' Repertory Grid. *Selbstorganisation, Kooperation, Zeichenprozess: -#' Arbeiten zu einer kulturwissenschaftlichen, anwendungsbezogenen -#' Psychologie* (pp. 209-254). Opladen: Westdeutscher Verlag. -#' -#' @examples \dontrun{ -#' -#' biplot3d(boeker) -#' biplot3d(boeker, unity3d=T) -#' -#' biplot3d(boeker, e.sphere.col="red", -#' c.text.col="blue") -#' biplot3d(boeker, e.cex=1) -#' biplot3d(boeker, col.sphere="red") -#' -#' biplot3d(boeker, g=1, h=1) # INGRID biplot -#' biplot3d(boeker, g=1, h=1, # ESA biplot -#' center=4) -#' } -#' -biplot3d <- function(x, dim=1:3, labels.e=TRUE, labels.c=TRUE, lines.c=TRUE, - lef=1.3, center=1, normalize=0, g=0, h=1, col.active=NA, - col.passive=NA, - c.sphere.col =grey(.4), c.cex=.6, c.text.col=grey(.4), - e.sphere.col =grey(0), e.cex=.6, e.text.col=grey(0), - alpha.sphere=.05, col.sphere="black", - unity=FALSE, - unity3d=FALSE, - scale.e=.9, zoom=1, ...) -{ - biplot3dBase2(x=x, dim=dim, labels.e=labels.e, labels.c=labels.c, lines.c=lines.c, - lef=lef, center=center, normalize=normalize, g=g, h=h, - col.active=col.active, col.passive=col.passive, - c.sphere.col =c.sphere.col, c.cex=c.cex, c.text.col=c.text.col, - e.sphere.col =e.sphere.col, e.cex=e.cex, e.text.col=e.text.col, - alpha.sphere=alpha.sphere, col.sphere=col.sphere, - unity=unity, unity3d=unity3d, scale.e=scale.e, zoom=zoom, ...) -} - - -#' Draw the Slater's INGRID biplot in rgl (3D device). -#' -#' The 3D biplot opens an interactive -#' 3D device that can be rotated and zoomed using the mouse. -#' A 3D device facilitates the exploration of grid data as -#' significant proportions of the sum-of-squares are often -#' represented beyond the first two dimensions. Also, in a lot of -#' cases it may be of interest to explore the grid space from -#' a certain angle, e.g. to gain an optimal view onto the set -#' of elements under investigation (e.g. Raeithel, 1998). -#' Note that Slater's biplot is just a special case of a biplot -#' that can be produced using the [biplot3d()] -#' function with the arguments `center=1, g=1, h=1`. -#' -#' @param x `repgrid` object. -#' @param center Numeric. The type of centering to be performed. -#' 0= no centering, 1= row mean centering (construct), -#' 2= column mean centering (elements), 3= double-centering (construct and element means), -#' 4= midpoint centering of rows (constructs). -#' Default is `1` (row i.e. construct centering). -#' @param g Power of the singular value matrix assigned to the left singular -#' vectors, i.e. the constructs. -#' @param h Power of the singular value matrix assigned to the right singular -#' vectors, i.e. the elements. -#' @param ... Additional arguments to be passed to biplot3d. -#' @export -#' -#' @seealso Unsophisticated biplot: [biplotSimple()]; \cr -#' 2D biplots: -#' [biplot2d()], -#' [biplotEsa2d()], -#' [biplotSlater2d()];\cr -#' Pseudo 3D biplots: -#' [biplotPseudo3d()], -#' [biplotEsaPseudo3d()], -#' [biplotSlaterPseudo3d()];\cr -#' Interactive 3D biplots: -#' [biplot3d()], -#' [biplotEsa3d()], -#' [biplotSlater3d()];\cr -#' Function to set view in 3D: -#' [home()]. -#' -#' @examples \dontrun{ -#' -#' biplotSlater3d(boeker) -#' biplotSlater3d(boeker, unity3d=T) -#' -#' biplotSlater3d(boeker, e.sphere.col="red", -#' c.text.col="blue") -#' biplotSlater3d(boeker, e.cex=1) -#' biplotSlater3d(boeker, col.sphere="red") -#' -#' } -#' -biplotSlater3d <- function(x, center=1, g=1, h=1, ...){ - biplot3d(x=x, center=center, g=g, h=h, ...) -} - - -#' Draw the eigenstructure analysis (ESA) biplot in rgl (3D device). -#' -#' The 3D biplot opens an interactive -#' 3D device that can be rotated and zoomed using the mouse. -#' A 3D device facilitates the exploration of grid data as -#' significant proportions of the sum-of-squares are often -#' represented beyond the first two dimensions. Also, in a lot of -#' cases it may be of interest to explore the grid space from -#' a certain angle, e.g. to gain an optimal view onto the set -#' of elements under investigation (e.g. Raeithel, 1998). -#' Note that the eigenstructure analysis just a special case -#' of a biplot that can also be produced using the -#' [biplot3d()] function with the arguments -#' `center=4, g=1, h=1`. -#' -#' @param x `repgrid` object. -#' @param center Numeric. The type of centering to be performed. -#' 0= no centering, 1= row mean centering (construct), -#' 2= column mean centering (elements), 3= double-centering (construct and element means), -#' 4= midpoint centering of rows (constructs). -#' Default is `4` (scale midpoint centering). -#' @param g Power of the singular value matrix assigned to the left singular -#' vectors, i.e. the constructs. -#' @param h Power of the singular value matrix assigned to the right singular -#' vectors, i.e. the elements. -#' @param ... Additional arguments to be passed to [biplot3d()]. -#' @export -#' @seealso Unsophisticated biplot: [biplotSimple()]; \cr -#' 2D biplots: -#' [biplot2d()], -#' [biplotEsa2d()], -#' [biplotSlater2d()];\cr -#' Pseudo 3D biplots: -#' [biplotPseudo3d()], -#' [biplotEsaPseudo3d()], -#' [biplotSlaterPseudo3d()];\cr -#' Interactive 3D biplots: -#' [biplot3d()], -#' [biplotEsa3d()], -#' [biplotSlater3d()];\cr -#' Function to set view in 3D: -#' [home()]. -#' -#' @examples \dontrun{ -#' -#' biplotEsa3d(boeker) -#' biplotEsa3d(boeker, unity3d=T) -#' -#' biplotEsa3d(boeker, e.sphere.col="red", -#' c.text.col="blue") -#' biplotEsa3d(boeker, e.cex=1) -#' biplotEsa3d(boeker, col.sphere="red") -#' -#' } -#' -biplotEsa3d <- function(x, center=1, g=1, h=1, ...){ - biplot3d(x=x, center=center, g=g, h=h, ...) -} - - -#' Rotate the interactive 3D device to default views. -#' -#' Rotate the interactive 3D device to a default viewpoint or -#' to a position defined by `theta` and `phi` in Euler angles. -#' Three default viewpoints are implemented rendering a view -#' so that two axes span a plane and the third axis is -#' pointing out of the screen. -#' -#' @param view Numeric. Specifying one of three default views. -#' 1 = XY, 2=XZ and 3=YZ-plane. -#' @param theta Numeric. Euler angle. Overrides view setting. -#' @param phi Numeric. Euler angle. Overrides view setting. -#' -#' return `NULL`. -#' @export -#' @seealso Interactive 3D biplots: -#' [biplot3d()], -#' [biplotSlater3d()], -#' [biplotEsa3d()]. -#' -#' @examples \dontrun{ -#' -#' biplot3d(boeker) -#' home(2) -#' home(3) -#' home(1) -#' home(theta=45, phi=45) -#' -#' } -#' -home <- function(view=1, theta=NULL, phi=NULL){ - if (!view %in% 1:3) - stop("'view' must take a numeric value between 1 and 3") - p3d <- par3d() - if (is.null(theta) & is.null(phi)){ - if (view == 1){ - theta <- 0; phi <- 0 - } else if (view == 2){ - theta <- 0; phi <- 90 - } else if (view == 3){ - theta <- 90; phi <- 0 - } - } - view3d(theta = theta, phi = phi, zoom=p3d$zoom) # change 3d view angle -} - - - - -#////////////////////////////////////////////////////////////////////////////// -### EXAMPLES ### -#////////////////////////////////////////////////////////////////////////////// - -# biplot3d(raeithel, labels.c=F) -# -# x <- raeithel -# x <- calcBiplotCoords(x, g=0, h=1, midp=T, col.active=c(2,4,10)) -# x <- prepareBiplotData(x, unity=T) -# biplot3d(x) - -# -# M <- par3d("userMatrix") # get current position matrix -# dir <- "/Users/markheckmann/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/output/animation" -# M1 <- rotate3d(M, pi/2, 1, 0, 0) -# M2 <- rotate3d(M1, pi/2, 0, 0, 1) -# movie3d(par3dinterp( userMatrix=list(M, M1, M2, M1, M), method="linear"), -# duration=4, fps=20, convert=F, clean=F, dir=dir) - - -# open3d() -# lines3d(c(0, 1), c(0,0), c(0,0)) -# lines3d(c(0,0), c(0, 1), c(0,0)) -# lines3d(c(0,0), c(0,0), c(0, 1)) - - - - -# mouseTrackballOrigin <- function(button = 1, dev = cur3d(), origin=c(0,0,0) ) { -# width <- height <- rotBase <- NULL -# userMatrix <- list() -# cur <- cur3d() -# offset <- NULL -# scale <- NULL -# -# screenToVector <- function(x, y) { -# radius <- max(width, height)/2 -# centre <- c(width, height)/2 -# pt <- (c(x, y) - centre)/radius -# len <- vlen(pt) -# -# if (len > 1.e-6) pt <- pt/len -# -# maxlen <- sqrt(2) -# angle <- (maxlen - len)/maxlen*pi/2 -# z <- sin(angle) -# len <- sqrt(1 - z^2) -# pt <- pt * len -# return (c(pt, z)) -# } -# -# trackballBegin <- function(x, y) { -# vp <- par3d("viewport") -# width <<- vp[3] -# height <<- vp[4] -# cur <<- cur3d() -# bbox <- par3d("bbox") -# center <- c(sum(bbox[1:2])/2, sum(bbox[3:4])/2, sum(bbox[5:6])/2) -# scale <<- par3d("scale") -# offset <<- (center - origin)*scale -# for (i in dev) { -# if (inherits(try(set3d(i, TRUE)), "try-error")) dev <<- dev[dev != i] -# else userMatrix[[i]] <<- par3d("userMatrix") -# } -# set3d(cur, TRUE) -# rotBase <<- screenToVector(x, height - y) -# } -# -# trackballUpdate <- function(x,y) { -# rotCurrent <- screenToVector(x, height - y) -# angle <- angle(rotBase, rotCurrent) -# axis <- xprod(rotBase, rotCurrent) -# mouseMatrix <- rotationMatrix(angle, axis[1], axis[2], axis[3]) -# for (i in dev) { -# if (inherits(try(set3d(i, TRUE)), "try-error")) dev <<- dev[dev != i] -# else par3d(userMatrix = t(translationMatrix(-offset[1], -offset[2], -offset[3])) %*% mouseMatrix %*% t(translationMatrix(offset[1], offset[2], offset[3])) %*%userMatrix[[i]]) -# } -# set3d(cur, TRUE) -# } -# -# for (i in dev) { -# set3d(i, TRUE) -# rgl.setMouseCallbacks(button, begin = trackballBegin, update = trackballUpdate, end = NULL) -# } -# set3d(cur, TRUE) -# } - -# additioally load functions from demo(). see email from Duncan Murdoch 25.04.2011 -# mouseTrackballOrigin() - - -#////////////////////////////////////////////////////////////////////////////// - -# TODO: rotations of the biplot -# -# eulerxyz <- function(phi, theta, psi){ -# phi <- phi*180/pi # conversion from degree to radians -# theta <- theta*180/pi -# psi <- psi*180/pi -# -# matrix(c(cos(theta)*cos(psi), -cos(phi)*sin(psi) + sin(phi)*sin(theta)*cos(psi), sin(phi)*sin(psi)+ cos(phi)*sin(theta)*cos(psi), -# cos(theta)*sin(psi), cos(phi)*cos(psi) + sin(phi)*sin(theta)*sin(psi), -sin(phi)*cos(psi) + cos(phi)*sin(theta)*sin(psi), -# -sin(theta) , sin(phi)*cos(theta) , cos(phi)*cos(theta)), ncol=3) -# } -# -# m <- par3d()$userMatrix[1:3, 1:3] - - +#' Draw standard axes in the origin in an rgl plot. +#' +#' @param max.dim maximum length of axis. +#' @param lwd line width. +#' @param a.cex cex for axis labels. +#' @param a.col axis color. +#' @param a.radius radius of spheres at the end points of the axes. +#' @param labels logical. whether to draw axis labels. +#' @param spheres logical. whether to draw axis spheres at the end points. +#' @param ... not evaluated. +#' @export +#' @keywords internal +rglDrawStandardAxes <- function(max.dim = 1, lwd = 1, a.cex = 1.1, a.col = "black", + a.radius = .05, labels = TRUE, spheres = FALSE, ...) { + lines3d(c(0, max.dim), c(0, 0), c(0, 0), lwd = lwd, col = a.col) + lines3d(c(0, 0), c(0, max.dim), c(0, 0), lwd = lwd, col = a.col) + lines3d(c(0, 0), c(0, 0), c(0, max.dim), lwd = lwd, col = a.col) + if (labels) { + text3d(max.dim, 0, 0, "X", cex = a.cex, adj = c(1, 1), col = a.col) + text3d(0, max.dim, 0, "Y", cex = a.cex, adj = c(1, 1), col = a.col) + text3d(0, 0, max.dim, "Z", cex = a.cex, adj = c(1, 1), col = a.col) + } + if (spheres) { + spheres3d(max.dim, 0, 0, radius = a.radius, col = a.col) + spheres3d(0, max.dim, 0, radius = a.radius, col = a.col) + spheres3d(0, 0, max.dim, radius = a.radius, col = a.col) + } +} +# open3d() +# points3d(rnorm(1000), rnorm(1000), rnorm(1000), color=heat.colors(1000)) +# rglDrawStandardAxes(3) + + +#' Draw standard ellipses in the origin in an rgl plot. +#' +#' @param max.dim soon +#' @param lwd soon +#' @param col soon +#' @export +#' @keywords internal +#' +rglDrawStandardEllipses <- function(max.dim = 1, lwd = 1, col = "black") { + x <- seq(0, 2 * pi, len = 361) + x <- data.frame(sin(x), cos(x)) * max.dim + lines3d(x[, 1], x[, 2], 0, col = col, lwd = lwd) + lines3d(x[, 1], 0, x[, 2], col = col, lwd = lwd) + lines3d(0, x[, 1], x[, 2], col = col, lwd = lwd) +} + + + +rglDrawElementPoints <- function(coords, dim = 1:3, e.radius = .1, e.sphere.col = "black", ...) { + coords <- coords[, dim] + spheres3d(coords[, 1], coords[, 2], coords[, 3], + radius = e.radius, color = e.sphere.col, aspect = F + ) +} + + +rglDrawElementLabels <- function(coords, labels = FALSE, dim = 1:3, e.radius = .1, e.cex = .6, e.text.col = "black", ...) { + coords <- coords[, dim] + if (!identical(labels, FALSE)) { + coords.text <- coords - e.radius / 2 # offset text for elements + texts3d( + x = coords.text[, 1], + y = coords.text[, 2], + z = coords.text[, 3], + texts = labels, adj = c(1, 1), cex = e.cex, col = e.text.col, aspect = F + ) + } +} + + +#' draw constructs in rgl +#' +#' @param coords coordinates for construct points. +#' @param dim dimensions of coordinates to use. +#' @param c.radius radius of construct spheres. +#' @param c.sphere.col color of construct spheres. +#' @param ... not evaluated. +#' @export +#' @keywords internal +#' +rglDrawConstructPoints <- function(coords, dim = 1:3, c.radius = .02, c.sphere.col = grey(.4), + ...) { + coords <- coords[, dim] + coords[is.na(coords)] <- 0 # replace NAs by zero, so Na can be entered as dim for 2d projection + spheres3d(coords[, dim], radius = c.radius, color = c.sphere.col) +} + +#' draw constructs in rgl +#' +#' @param coords coordinates for constructs labels. +#' @param labels labels for constructs. +#' @param dim dimensions of coordinates to use. +#' @param c.cex cex for construct text. +#' @param c.text.col color for construct text. +#' @param ... not evaluated. +#' @export +#' @keywords internal +#' +rglDrawConstructLabels <- function(coords, labels = FALSE, dim = 1:3, + c.cex = .6, c.text.col = grey(.4), ...) { + coords <- coords[, dim] + coords[is.na(coords)] <- 0 # replace NAs by zero, so Na can be entered as dim for 2d projection + if (!identical(labels, FALSE)) { + texts3d(coords, + texts = labels, adj = c(.5, .5), + cex = c.cex, col = c.text.col, aspect = F + ) + } +} + + +#' biplot3dBase2 is the workhorse to draw a grid in rgl (3D device). +#' +#' @param x `repgrid` object. +#' @param dim Dimensions to display. +#' @param labels.e Logical. whether element labels are displayed. +#' @param labels.c Logical. whether construct labels are displayed. +#' @param lines.c Numeric. The way lines are drawn through the construct vectors. +#' `0 =` no lines, `1 =` lines from constructs to outer frame, +#' `2 =` lines from the center to outer frame. +#' @param lef Construct lines extension factor. +#' @param alpha.sphere Numeric. alpha blending of the surrounding sphere (default`".05"`). +#' @param col.sphere Color of surrounding sphere (default`"black"`). +#' @param ext.sphere Extension factor for sphere +#' @param col.frame Color of the surrounding frame. +#' @param zoom Not yet used. Scaling factor for all vectors. Can be used to zoom +#' the plot in and out (default `1`). +#' @param draw.xyz.axes Draw standard XYZ axes. +#' @param ... Parameters to be passed on. +#' @keywords internal +#' @export +#' +biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines.c = 1, + lef = 1.1, frame = 1, col.frame = grey(.6), + col.sphere = "black", alpha.sphere = .05, zoom = 1, + draw.xyz.axes = TRUE, + # c.points.show=TRUE, + # c.labels.show=TRUE, + # e.points.show=TRUE, + # e.labels.show=TRUE, + ...) { + x <- calcBiplotCoords(x, ...) + x <- prepareBiplotData(x, ...) + + showpoint <- showlabel <- type <- NULL # to prevent 'R CMD check' from noting a missing binding + # as the variables are provided in object x as default + open3d() # open rgl device + par3d(params = list( + windowRect = c(100, 100, 600, 600) + )) # enlarge and position 3d device + view3d(theta = 0, phi = 0, zoom = .6) # change 3d view angle + bg3d(color = "white") # set background color + + # select spheres to draw and labels to show + # select which elements to show + if (identical(labels.e, TRUE)) { + labels.e <- elements(x) + } + if (identical(labels.c, TRUE)) { + labels.l <- constructs(x)$leftpole + labels.r <- constructs(x)$rightpole + } else { + labels.r <- FALSE + labels.l <- FALSE + } + + X <- x@calcs$biplot$X # pre-transformed (centered etc.) grid matrix + Eu <- x@calcs$biplot$e.unity # element coordinates scaled/unified + Cu <- x@calcs$biplot$c.unity # construct coordinates scaled/unified + + pdat <- x@plotdata # plotdata prepared by prepareBiplotData() + + mval <- max(abs(rbind(Eu[, dim], Cu[, dim])), # get maximum value of construct and element coordinates + na.rm = TRUE + ) + + # Eu <- Eu * zoom + # Cu <- Cu * zoom + + # prolongation of construct vector to outer side + Cu.norm <- apply(Cu[, dim]^2, 1, sum, na.rm = TRUE)^.5 + Cup <- Cu[, dim] / Cu.norm * (lef * mval) + + # plot element spheres + es.p <- subset(pdat, type == "e" & showpoint == T) + rglDrawElementPoints(es.p[c("x", "y", "z")], e.radius = mval / 50, ...) + # labels for elements + es.l <- subset(pdat, type == "e" & showlabel == T & showpoint == T) + rglDrawElementLabels(es.l[c("x", "y", "z")], labels = es.l$label, e.radius = mval / 50, ...) + + standardizeCoords <- function(x, dim = 1:3) { + x.norm <- apply(x[, dim]^2, 1, sum, na.rm = TRUE)^.5 + xsc <- x[, dim] / x.norm * (lef * mval) + xsc + } + + # make construct spheres + cs.p <- subset(pdat, type %in% c("cl", "cr") & showpoint == T) + cs.p.xyz <- cs.p[c("x", "y", "z")] + # labels for constructs + cs.l <- subset(pdat, type %in% c("cl", "cr") & showlabel == T) + cl.l.xyz <- cs.l[c("x", "y", "z")] + cl.l.xyz.outer <- standardizeCoords(cs.l[c("x", "y", "z")]) + + if (lines.c == 0) { # no construct lines labels at cons pos + rglDrawConstructLabels(cl.l.xyz, labels = cs.l$label, ...) + if (draw.xyz.axes) rglDrawStandardAxes(mval, spheres = F) + # rglDrawConstructLabels(Cu[, dim], labels=labels.r, ...) + # rglDrawConstructLabels(-Cu[, dim], labels=labels.l, ...) + } else if (lines.c == 1) { # construct lines from cons pos to outside + segments3d(interleave(cl.l.xyz, cl.l.xyz.outer), col = "grey") + rglDrawConstructLabels(cl.l.xyz.outer, labels = cs.l$label, ...) + if (draw.xyz.axes) rglDrawStandardAxes(lef * mval, a.col = "black") + # segments3d(interleave(-Cu[, dim], -Cup), col="grey") # Cu and Cup from older implementation without use if x@plotdata + # rglDrawConstructLabels(Cup, labels=labels.r, ...) + # rglDrawConstructLabels(-Cup, labels=labels.l, ...) + } else if (lines.c == 2) { # construct lines from center to outside + nm <- matrix(0, ncol = 3, nrow = nrow(cl.l.xyz.outer)) + segments3d(interleave(nm, as.matrix(cl.l.xyz.outer)), col = "grey") + rglDrawConstructLabels(cl.l.xyz.outer, labels = cs.l$label, ...) + if (draw.xyz.axes) rglDrawStandardAxes(lef * mval, a.col = "black") + } else { + stop("'lines.c' can only take numeric values from 0 to 2") + } + rglDrawConstructPoints(cs.p.xyz, c.radius = mval / 200, ...) + # rglDrawConstructPoints(-Cu[, dim], c.radius=mval/200, ...) + # rglDrawStandardEllipses(max.dim) + + # trick to make user coordinate system's origin the center of rotation + mval <- max(abs(par3d()$bbox)) # get max value in x,y,z + ps <- interleave(mval * diag(3), -mval * (diag(3))) + spheres3d(ps, radius = 0) # draw invisible spheres at the extremes + + # select type of frame ariound the whole plot + # 0=none, 1= simple box, 2= box with grid, 3=sphere. + if (frame == 1) { + # make box around device + ss <- matrix(c( + mval, mval, mval, # top + -mval, mval, mval, + -mval, mval, mval, + -mval, -mval, mval, + -mval, -mval, mval, + mval, -mval, mval, + mval, -mval, mval, + mval, mval, mval, + mval, mval, -mval, # bottom + -mval, mval, -mval, + -mval, mval, -mval, + -mval, -mval, -mval, + -mval, -mval, -mval, + mval, -mval, -mval, + mval, -mval, -mval, + mval, mval, -mval, + mval, mval, mval, # sides + mval, mval, -mval, + -mval, mval, mval, + -mval, mval, -mval, + -mval, -mval, mval, + -mval, -mval, -mval, + mval, -mval, mval, + mval, -mval, -mval + ), ncol = 3, byrow = T) + segments3d(ss, col = col.frame) + } else if (frame == 2) { + grid3d(c("x+", "x-", "y+", "y-", "z+", "z-")) + } else if (frame == 3) { + # sphere for easier 3D impression if prompted + spheres3d(0, 0, 0, + radius = mval, color = col.sphere, + alpha = alpha.sphere, aspect = F, front = "lines", back = "lines" + ) + } +} + + + +#' Draw grid in rgl (3D device). +#' +#' The 3D biplot opens an interactive +#' 3D device that can be rotated and zoomed using the mouse. +#' A 3D device facilitates the exploration of grid data as +#' significant proportions of the sum-of-squares are often +#' represented beyond the first two dimensions. Also, in a lot of +#' cases it may be of interest to explore the grid space from +#' a certain angle, e.g. to gain an optimal view onto the set +#' of elements under investigation (e.g. Raeithel, 1998). +#' +#' @param x `repgrid` object. +#' @param dim Dimensions to display. +#' @param labels.e Logical. whether element labels are displayed. +#' @param labels.c Logical. whether construct labels are displayed. +#' @param lines.c Numeric. The way lines are drawn through the construct vectors. +#' `0 =` no lines, `1 =` lines from constructs to outer frame, +#' `2 =` lines from the center to outer frame. +#' @param lef Construct lines extension factor +#' +#' @param center Numeric. The type of centering to be performed. +#' 0= no centering, 1= row mean centering (construct), +#' 2= column mean centering (elements), 3= double-centering (construct and element means), +#' 4= midpoint centering of rows (constructs). +#' Default is `1` (row centering). +#' +#' @param normalize A numeric value indicating along what direction (rows, columns) +#' to normalize by standard deviations. `0 = none, 1= rows, 2 = columns` +#' (default is `0`). +#' @param g Power of the singular value matrix assigned to the left singular +#' vectors, i.e. the constructs. +#' @param h Power of the singular value matrix assigned to the right singular +#' vectors, i.e. the elements. +#' @param col.active Columns (elements) that are no supplementary points, i.e. they are used +#' in the SVD to find principal components. default is to use all elements. +#' @param col.passive Columns (elements) that are supplementary points, i.e. they are NOT used +#' in the SVD but projected into the component space afterwards. They do not +#' determine the solution. Default is `NA`, i.e. no elements are set +#' supplementary. +#' +#' @param c.sphere.col Color of construct spheres. +#' @param c.cex Size of construct text. +#' @param c.text.col Color for construct text. +#' +#' @param e.sphere.col Color of elements. +#' @param e.cex Size of element labels. +#' @param e.text.col Color of element labels. +#' +#' @param alpha.sphere Numeric. alpha blending of the surrounding sphere (default`".05"`). +#' @param col.sphere Color of surrounding sphere (default`"black"`). +#' +#' @param unity Scale elements and constructs coordinates to unit scale (maximum of 1) +#' so they are printed more neatly (default `TRUE`). +#' @param unity3d To come. +#' @param scale.e Scaling factor for element vectors. Will cause element points to move a bit more +#' to the center (but only if `unity` or `unity3d` is `TRUE`). +#' This argument is for visual appeal only. +#' @param zoom Not yet used. Scaling factor for all vectors. Can be used to zoom +#' the plot in and out (default `1`). +#' @param ... Parameters to be passed on. +#' @export +#' @seealso Unsophisticated biplot: [biplotSimple()]; \cr +#' 2D biplots: +#' [biplot2d()], +#' [biplotEsa2d()], +#' [biplotSlater2d()];\cr +#' Pseudo 3D biplots: +#' [biplotPseudo3d()], +#' [biplotEsaPseudo3d()], +#' [biplotSlaterPseudo3d()];\cr +#' Interactive 3D biplots: +#' [biplot3d()], +#' [biplotEsa3d()], +#' [biplotSlater3d()];\cr +#' Function to set view in 3D: +#' [home()]. +#' +#' @references Raeithel, A. (1998). Kooperative Modellproduktion von +#' Professionellen und Klienten - erlauetert am Beispiel des +#' Repertory Grid. *Selbstorganisation, Kooperation, Zeichenprozess: +#' Arbeiten zu einer kulturwissenschaftlichen, anwendungsbezogenen +#' Psychologie* (pp. 209-254). Opladen: Westdeutscher Verlag. +#' +#' @examples \dontrun{ +#' +#' biplot3d(boeker) +#' biplot3d(boeker, unity3d = T) +#' +#' biplot3d(boeker, +#' e.sphere.col = "red", +#' c.text.col = "blue" +#' ) +#' biplot3d(boeker, e.cex = 1) +#' biplot3d(boeker, col.sphere = "red") +#' +#' biplot3d(boeker, g = 1, h = 1) # INGRID biplot +#' biplot3d(boeker, +#' g = 1, h = 1, # ESA biplot +#' center = 4 +#' ) +#' } +#' +biplot3d <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines.c = TRUE, + lef = 1.3, center = 1, normalize = 0, g = 0, h = 1, col.active = NA, + col.passive = NA, + c.sphere.col = grey(.4), c.cex = .6, c.text.col = grey(.4), + e.sphere.col = grey(0), e.cex = .6, e.text.col = grey(0), + alpha.sphere = .05, col.sphere = "black", + unity = FALSE, + unity3d = FALSE, + scale.e = .9, zoom = 1, ...) { + biplot3dBase2( + x = x, dim = dim, labels.e = labels.e, labels.c = labels.c, lines.c = lines.c, + lef = lef, center = center, normalize = normalize, g = g, h = h, + col.active = col.active, col.passive = col.passive, + c.sphere.col = c.sphere.col, c.cex = c.cex, c.text.col = c.text.col, + e.sphere.col = e.sphere.col, e.cex = e.cex, e.text.col = e.text.col, + alpha.sphere = alpha.sphere, col.sphere = col.sphere, + unity = unity, unity3d = unity3d, scale.e = scale.e, zoom = zoom, ... + ) +} + + +#' Draw the Slater's INGRID biplot in rgl (3D device). +#' +#' The 3D biplot opens an interactive +#' 3D device that can be rotated and zoomed using the mouse. +#' A 3D device facilitates the exploration of grid data as +#' significant proportions of the sum-of-squares are often +#' represented beyond the first two dimensions. Also, in a lot of +#' cases it may be of interest to explore the grid space from +#' a certain angle, e.g. to gain an optimal view onto the set +#' of elements under investigation (e.g. Raeithel, 1998). +#' Note that Slater's biplot is just a special case of a biplot +#' that can be produced using the [biplot3d()] +#' function with the arguments `center=1, g=1, h=1`. +#' +#' @param x `repgrid` object. +#' @param center Numeric. The type of centering to be performed. +#' 0= no centering, 1= row mean centering (construct), +#' 2= column mean centering (elements), 3= double-centering (construct and element means), +#' 4= midpoint centering of rows (constructs). +#' Default is `1` (row i.e. construct centering). +#' @param g Power of the singular value matrix assigned to the left singular +#' vectors, i.e. the constructs. +#' @param h Power of the singular value matrix assigned to the right singular +#' vectors, i.e. the elements. +#' @param ... Additional arguments to be passed to biplot3d. +#' @export +#' +#' @seealso Unsophisticated biplot: [biplotSimple()]; \cr +#' 2D biplots: +#' [biplot2d()], +#' [biplotEsa2d()], +#' [biplotSlater2d()];\cr +#' Pseudo 3D biplots: +#' [biplotPseudo3d()], +#' [biplotEsaPseudo3d()], +#' [biplotSlaterPseudo3d()];\cr +#' Interactive 3D biplots: +#' [biplot3d()], +#' [biplotEsa3d()], +#' [biplotSlater3d()];\cr +#' Function to set view in 3D: +#' [home()]. +#' +#' @examples \dontrun{ +#' +#' biplotSlater3d(boeker) +#' biplotSlater3d(boeker, unity3d = T) +#' +#' biplotSlater3d(boeker, +#' e.sphere.col = "red", +#' c.text.col = "blue" +#' ) +#' biplotSlater3d(boeker, e.cex = 1) +#' biplotSlater3d(boeker, col.sphere = "red") +#' } +#' +biplotSlater3d <- function(x, center = 1, g = 1, h = 1, ...) { + biplot3d(x = x, center = center, g = g, h = h, ...) +} + + +#' Draw the eigenstructure analysis (ESA) biplot in rgl (3D device). +#' +#' The 3D biplot opens an interactive +#' 3D device that can be rotated and zoomed using the mouse. +#' A 3D device facilitates the exploration of grid data as +#' significant proportions of the sum-of-squares are often +#' represented beyond the first two dimensions. Also, in a lot of +#' cases it may be of interest to explore the grid space from +#' a certain angle, e.g. to gain an optimal view onto the set +#' of elements under investigation (e.g. Raeithel, 1998). +#' Note that the eigenstructure analysis just a special case +#' of a biplot that can also be produced using the +#' [biplot3d()] function with the arguments +#' `center=4, g=1, h=1`. +#' +#' @param x `repgrid` object. +#' @param center Numeric. The type of centering to be performed. +#' 0= no centering, 1= row mean centering (construct), +#' 2= column mean centering (elements), 3= double-centering (construct and element means), +#' 4= midpoint centering of rows (constructs). +#' Default is `4` (scale midpoint centering). +#' @param g Power of the singular value matrix assigned to the left singular +#' vectors, i.e. the constructs. +#' @param h Power of the singular value matrix assigned to the right singular +#' vectors, i.e. the elements. +#' @param ... Additional arguments to be passed to [biplot3d()]. +#' @export +#' @seealso Unsophisticated biplot: [biplotSimple()]; \cr +#' 2D biplots: +#' [biplot2d()], +#' [biplotEsa2d()], +#' [biplotSlater2d()];\cr +#' Pseudo 3D biplots: +#' [biplotPseudo3d()], +#' [biplotEsaPseudo3d()], +#' [biplotSlaterPseudo3d()];\cr +#' Interactive 3D biplots: +#' [biplot3d()], +#' [biplotEsa3d()], +#' [biplotSlater3d()];\cr +#' Function to set view in 3D: +#' [home()]. +#' +#' @examples \dontrun{ +#' +#' biplotEsa3d(boeker) +#' biplotEsa3d(boeker, unity3d = T) +#' +#' biplotEsa3d(boeker, +#' e.sphere.col = "red", +#' c.text.col = "blue" +#' ) +#' biplotEsa3d(boeker, e.cex = 1) +#' biplotEsa3d(boeker, col.sphere = "red") +#' } +#' +biplotEsa3d <- function(x, center = 1, g = 1, h = 1, ...) { + biplot3d(x = x, center = center, g = g, h = h, ...) +} + + +#' Rotate the interactive 3D device to default views. +#' +#' Rotate the interactive 3D device to a default viewpoint or +#' to a position defined by `theta` and `phi` in Euler angles. +#' Three default viewpoints are implemented rendering a view +#' so that two axes span a plane and the third axis is +#' pointing out of the screen. +#' +#' @param view Numeric. Specifying one of three default views. +#' 1 = XY, 2=XZ and 3=YZ-plane. +#' @param theta Numeric. Euler angle. Overrides view setting. +#' @param phi Numeric. Euler angle. Overrides view setting. +#' +#' return `NULL`. +#' @export +#' @seealso Interactive 3D biplots: +#' [biplot3d()], +#' [biplotSlater3d()], +#' [biplotEsa3d()]. +#' +#' @examples \dontrun{ +#' +#' biplot3d(boeker) +#' home(2) +#' home(3) +#' home(1) +#' home(theta = 45, phi = 45) +#' } +#' +home <- function(view = 1, theta = NULL, phi = NULL) { + if (!view %in% 1:3) { + stop("'view' must take a numeric value between 1 and 3") + } + p3d <- par3d() + if (is.null(theta) & is.null(phi)) { + if (view == 1) { + theta <- 0 + phi <- 0 + } else if (view == 2) { + theta <- 0 + phi <- 90 + } else if (view == 3) { + theta <- 90 + phi <- 0 + } + } + view3d(theta = theta, phi = phi, zoom = p3d$zoom) # change 3d view angle +} + + + + +# ////////////////////////////////////////////////////////////////////////////// +### EXAMPLES ### +# ////////////////////////////////////////////////////////////////////////////// + +# biplot3d(raeithel, labels.c=F) +# +# x <- raeithel +# x <- calcBiplotCoords(x, g=0, h=1, midp=T, col.active=c(2,4,10)) +# x <- prepareBiplotData(x, unity=T) +# biplot3d(x) + +# +# M <- par3d("userMatrix") # get current position matrix +# dir <- "/Users/markheckmann/Documents/Magic Briefcase/DA openRepgrid/openrepgrid/basic/output/animation" +# M1 <- rotate3d(M, pi/2, 1, 0, 0) +# M2 <- rotate3d(M1, pi/2, 0, 0, 1) +# movie3d(par3dinterp( userMatrix=list(M, M1, M2, M1, M), method="linear"), +# duration=4, fps=20, convert=F, clean=F, dir=dir) + + +# open3d() +# lines3d(c(0, 1), c(0,0), c(0,0)) +# lines3d(c(0,0), c(0, 1), c(0,0)) +# lines3d(c(0,0), c(0,0), c(0, 1)) + + + + +# mouseTrackballOrigin <- function(button = 1, dev = cur3d(), origin=c(0,0,0) ) { +# width <- height <- rotBase <- NULL +# userMatrix <- list() +# cur <- cur3d() +# offset <- NULL +# scale <- NULL +# +# screenToVector <- function(x, y) { +# radius <- max(width, height)/2 +# centre <- c(width, height)/2 +# pt <- (c(x, y) - centre)/radius +# len <- vlen(pt) +# +# if (len > 1.e-6) pt <- pt/len +# +# maxlen <- sqrt(2) +# angle <- (maxlen - len)/maxlen*pi/2 +# z <- sin(angle) +# len <- sqrt(1 - z^2) +# pt <- pt * len +# return (c(pt, z)) +# } +# +# trackballBegin <- function(x, y) { +# vp <- par3d("viewport") +# width <<- vp[3] +# height <<- vp[4] +# cur <<- cur3d() +# bbox <- par3d("bbox") +# center <- c(sum(bbox[1:2])/2, sum(bbox[3:4])/2, sum(bbox[5:6])/2) +# scale <<- par3d("scale") +# offset <<- (center - origin)*scale +# for (i in dev) { +# if (inherits(try(set3d(i, TRUE)), "try-error")) dev <<- dev[dev != i] +# else userMatrix[[i]] <<- par3d("userMatrix") +# } +# set3d(cur, TRUE) +# rotBase <<- screenToVector(x, height - y) +# } +# +# trackballUpdate <- function(x,y) { +# rotCurrent <- screenToVector(x, height - y) +# angle <- angle(rotBase, rotCurrent) +# axis <- xprod(rotBase, rotCurrent) +# mouseMatrix <- rotationMatrix(angle, axis[1], axis[2], axis[3]) +# for (i in dev) { +# if (inherits(try(set3d(i, TRUE)), "try-error")) dev <<- dev[dev != i] +# else par3d(userMatrix = t(translationMatrix(-offset[1], -offset[2], -offset[3])) %*% mouseMatrix %*% t(translationMatrix(offset[1], offset[2], offset[3])) %*%userMatrix[[i]]) +# } +# set3d(cur, TRUE) +# } +# +# for (i in dev) { +# set3d(i, TRUE) +# rgl.setMouseCallbacks(button, begin = trackballBegin, update = trackballUpdate, end = NULL) +# } +# set3d(cur, TRUE) +# } + +# additioally load functions from demo(). see email from Duncan Murdoch 25.04.2011 +# mouseTrackballOrigin() + + +# ////////////////////////////////////////////////////////////////////////////// + +# TODO: rotations of the biplot +# +# eulerxyz <- function(phi, theta, psi){ +# phi <- phi*180/pi # conversion from degree to radians +# theta <- theta*180/pi +# psi <- psi*180/pi +# +# matrix(c(cos(theta)*cos(psi), -cos(phi)*sin(psi) + sin(phi)*sin(theta)*cos(psi), sin(phi)*sin(psi)+ cos(phi)*sin(theta)*cos(psi), +# cos(theta)*sin(psi), cos(phi)*cos(psi) + sin(phi)*sin(theta)*sin(psi), -sin(phi)*cos(psi) + cos(phi)*sin(theta)*sin(psi), +# -sin(theta) , sin(phi)*cos(theta) , cos(phi)*cos(theta)), ncol=3) +# } +# +# m <- par3d()$userMatrix[1:3, 1:3] diff --git a/R/settings.r b/R/settings.r index b7905b1d..16af0e80 100644 --- a/R/settings.r +++ b/R/settings.r @@ -1,186 +1,190 @@ -generateDefaultSettings <- function(){ - l <- list() - type <- list() - - # print grid to console - l$show.trim <- 30; type$show.trim="numeric" - l$show.cut <- 20; type$show.cut="numeric" - l$show.scale <- TRUE; type$show.scale="logical" - l$show.meta <- TRUE; type$show.meta="logical" - l$c.no <- TRUE; type$c.no="logical" - l$e.no <- TRUE; type$e.no="logical" - - class(l) <- "openrepgridSettings" - attr(l, "type") <- type - l -} - - -typecheck <- function(x, type){ - f <- switch(type, - logical=is.logical, - numeric=is.numeric) - f(x) -} - - -# x object of class openrepgridSettings -checkSettingsIntegrity <- function(x, do.print=TRUE){ - if (!methods::is(x, "openrepgridSettings")) - stop("settings integrity check cannot be performed", - "as objects class is not 'openrepgridSettings'") - types <- attr(x, "type") - np <- !mapply(typecheck, x, types) # not passed - if (any(np)) { - for (par.name in names(x[np])) - if (do.print) - cat("Parameter '", par.name, "' must be ", - types[[par.name]], "\n", sep="") - stop("error in definition of parameters") - } else { - return(TRUE) - } -} - - -setDefaultSettings <- function(){ - .OpenRepGridEnv$settings <- generateDefaultSettings() -} - - -#' global settings for OpenRepGrid -#' -#' @param ... Use parameter value pairs (`par1=val1, par2=val2`) to -#' change a parameter. Use parameter names to request -#' parameter's value (`"par1", "par2"`). -#' @note Currently the following parameters can be changed, ordered by topic. -#' The default value is shown in the brackets at the end of a line. -#' -#' *Printing grid to the console* -#' \itemize{ -#' \item{`show.scale`} {Show grid scale info? (`TRUE`) } -#' \item{`show.meta`} {Show grid meta data? (`TRUE`) } -#' \item{`show.trim`} {Number of chars to trim strings to (`30`) } -#' \item{`show.cut`} {Maximum number of characters printed on the sides of a grid (`20`) } -#' \item{`c.no`} {Print construct ID number? (`TRUE`) } -#' \item{`e.no`} {Print element ID number? (`TRUE`) } -#' } -#' @export -#' @examples \dontrun{ -#' # get current settings -#' settings() -#' -#' # get some parameters -#' settings("show.scale", "show.meta") -#' -#' # change parameters -#' bell2010 -#' -#' settings(show.meta=F) -#' bell2010 -#' -#' settings(show.scale=F, show.cut=30) -#' bell2010 -#' } -#' -settings <- function (...) -{ - parnames <- names(generateDefaultSettings()) - cur.settings <- .OpenRepGridEnv$settings - args <- list(...) - if (length(args) == 0) # get all arguments - return(cur.settings) - # get args - if (is.null(names(args)) & - all(unlist(lapply(args, is.character)))) { - pm <- pmatch(unlist(args), parnames) - #if (length(pm) == 1L) - # return(cur.settings[pm][[1L]]) - return(cur.settings[na.omit(pm)]) - } else { # set arguments - names(args) <- parnames[pmatch(names(args), parnames)] # partial matching of names - new.settings <- modifyList(cur.settings, args) # modify settings list - passed <- checkSettingsIntegrity(new.settings) - if (passed) { - .OpenRepGridEnv$settings <- new.settings # replace settings - invisible(new.settings) - } - } -} - - -#' subset method for openrepgridSettings class -#' @export -#' @rdname openrepgridSettings -#' @method [ openrepgridSettings -#' @keywords internal -#' -`[.openrepgridSettings` <- function(x, i, ...){ - types <- attr(x, "type") - x <- unclass(x) - x <- x[i] - attr(x, "type") <- types - class(x) <- "openrepgridSettings" - x -} - - -#' Print method for openrepgridSettings class -#' @export -#' @rdname openrepgridSettings -#' @method print openrepgridSettings -#' @keywords internal -#' -print.openrepgridSettings <- function(x, ...){ - cat("------------------------\n") - cat("Settings for OpenRepGrid\n") - cat("------------------------\n") - - cat("\nPrinting a grid to the console\n") - if (! is.null(x$show.scale)) cat("\tshow.scale :", x$show.scale, "(show grid scale info?)\n") - if (! is.null(x$show.meta)) cat("\tshow.meta :", x$show.meta, "(show grid meta data?)\n") - if (! is.null(x$show.trim)) cat("\tshow.trim :", x$show.trim, "(number of chars to trim strings to)\n") - if (! is.null(x$show.cut)) cat("\tshow.cut :", x$show.cut, "(max no of chars on the sides of a grid)\n") - if (! is.null(x$c.no)) cat("\tc.no :", x$c.no, "(print construct id?)\n") - if (! is.null(x$e.no)) cat("\te.no :", x$e.no, "(print element id?)\n") -} - - -#' Save OpenRepGrid settings -#' -#' The current settings of OpenRepGrid can be saved into a file with -#' the extension `.orgset`. -#' -#' @param file Path of the file to be saved to. -#' @export -settingsSave <- function(file) { - # TODO: check for orgset extension? - saveRDS(.OpenRepGridEnv$settings ,file=file) -} - - -#' Load OpenRepGrid settings -#' -#' OpenRepGrid settings saved in an a settings file with -#' the extension `.orgset` can be loaded to restore the -#' settings. -#' -#' @param file Path of the file to be loaded. -#' @export -settingsLoad <- function(file) { - orgset <- readRDS(file) - if (!methods::is(orgset, "openrepgridSettings")) - stop("file", file, "is no valid OpenRepGrid settings file") - .OpenRepGridEnv$settings <- orgset # save in environment in namespace -} - - - - - - - - - - - +generateDefaultSettings <- function() { + l <- list() + type <- list() + + # print grid to console + l$show.trim <- 30 + type$show.trim <- "numeric" + l$show.cut <- 20 + type$show.cut <- "numeric" + l$show.scale <- TRUE + type$show.scale <- "logical" + l$show.meta <- TRUE + type$show.meta <- "logical" + l$c.no <- TRUE + type$c.no <- "logical" + l$e.no <- TRUE + type$e.no <- "logical" + + class(l) <- "openrepgridSettings" + attr(l, "type") <- type + l +} + + +typecheck <- function(x, type) { + f <- switch(type, + logical = is.logical, + numeric = is.numeric + ) + f(x) +} + + +# x object of class openrepgridSettings +checkSettingsIntegrity <- function(x, do.print = TRUE) { + if (!methods::is(x, "openrepgridSettings")) { + stop( + "settings integrity check cannot be performed", + "as objects class is not 'openrepgridSettings'" + ) + } + types <- attr(x, "type") + np <- !mapply(typecheck, x, types) # not passed + if (any(np)) { + for (par.name in names(x[np])) { + if (do.print) { + cat("Parameter '", par.name, "' must be ", + types[[par.name]], "\n", + sep = "" + ) + } + } + stop("error in definition of parameters") + } else { + return(TRUE) + } +} + + +setDefaultSettings <- function() { + .OpenRepGridEnv$settings <- generateDefaultSettings() +} + + +#' global settings for OpenRepGrid +#' +#' @param ... Use parameter value pairs (`par1=val1, par2=val2`) to +#' change a parameter. Use parameter names to request +#' parameter's value (`"par1", "par2"`). +#' @note Currently the following parameters can be changed, ordered by topic. +#' The default value is shown in the brackets at the end of a line. +#' +#' *Printing grid to the console* +#' \itemize{ +#' \item{`show.scale`} {Show grid scale info? (`TRUE`) } +#' \item{`show.meta`} {Show grid meta data? (`TRUE`) } +#' \item{`show.trim`} {Number of chars to trim strings to (`30`) } +#' \item{`show.cut`} {Maximum number of characters printed on the sides of a grid (`20`) } +#' \item{`c.no`} {Print construct ID number? (`TRUE`) } +#' \item{`e.no`} {Print element ID number? (`TRUE`) } +#' } +#' @export +#' @examples \dontrun{ +#' # get current settings +#' settings() +#' +#' # get some parameters +#' settings("show.scale", "show.meta") +#' +#' # change parameters +#' bell2010 +#' +#' settings(show.meta = F) +#' bell2010 +#' +#' settings(show.scale = F, show.cut = 30) +#' bell2010 +#' } +#' +settings <- function(...) { + parnames <- names(generateDefaultSettings()) + cur.settings <- .OpenRepGridEnv$settings + args <- list(...) + if (length(args) == 0) { # get all arguments + return(cur.settings) + } + # get args + if (is.null(names(args)) & + all(unlist(lapply(args, is.character)))) { + pm <- pmatch(unlist(args), parnames) + # if (length(pm) == 1L) + # return(cur.settings[pm][[1L]]) + return(cur.settings[na.omit(pm)]) + } else { # set arguments + names(args) <- parnames[pmatch(names(args), parnames)] # partial matching of names + new.settings <- modifyList(cur.settings, args) # modify settings list + passed <- checkSettingsIntegrity(new.settings) + if (passed) { + .OpenRepGridEnv$settings <- new.settings # replace settings + invisible(new.settings) + } + } +} + + +#' subset method for openrepgridSettings class +#' @export +#' @rdname openrepgridSettings +#' @method [ openrepgridSettings +#' @keywords internal +#' +`[.openrepgridSettings` <- function(x, i, ...) { + types <- attr(x, "type") + x <- unclass(x) + x <- x[i] + attr(x, "type") <- types + class(x) <- "openrepgridSettings" + x +} + + +#' Print method for openrepgridSettings class +#' @export +#' @rdname openrepgridSettings +#' @method print openrepgridSettings +#' @keywords internal +#' +print.openrepgridSettings <- function(x, ...) { + cat("------------------------\n") + cat("Settings for OpenRepGrid\n") + cat("------------------------\n") + + cat("\nPrinting a grid to the console\n") + if (!is.null(x$show.scale)) cat("\tshow.scale :", x$show.scale, "(show grid scale info?)\n") + if (!is.null(x$show.meta)) cat("\tshow.meta :", x$show.meta, "(show grid meta data?)\n") + if (!is.null(x$show.trim)) cat("\tshow.trim :", x$show.trim, "(number of chars to trim strings to)\n") + if (!is.null(x$show.cut)) cat("\tshow.cut :", x$show.cut, "(max no of chars on the sides of a grid)\n") + if (!is.null(x$c.no)) cat("\tc.no :", x$c.no, "(print construct id?)\n") + if (!is.null(x$e.no)) cat("\te.no :", x$e.no, "(print element id?)\n") +} + + +#' Save OpenRepGrid settings +#' +#' The current settings of OpenRepGrid can be saved into a file with +#' the extension `.orgset`. +#' +#' @param file Path of the file to be saved to. +#' @export +settingsSave <- function(file) { + # TODO: check for orgset extension? + saveRDS(.OpenRepGridEnv$settings, file = file) +} + + +#' Load OpenRepGrid settings +#' +#' OpenRepGrid settings saved in an a settings file with +#' the extension `.orgset` can be loaded to restore the +#' settings. +#' +#' @param file Path of the file to be loaded. +#' @export +settingsLoad <- function(file) { + orgset <- readRDS(file) + if (!methods::is(orgset, "openrepgridSettings")) { + stop("file", file, "is no valid OpenRepGrid settings file") + } + .OpenRepGridEnv$settings <- orgset # save in environment in namespace +} diff --git a/R/utils-import.r b/R/utils-import.r index 5a19c736..0b662780 100644 --- a/R/utils-import.r +++ b/R/utils-import.r @@ -1,315 +1,395 @@ -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// ### Functions taken from other packages which shall not be loaded due to ### -### too much overhead or additional dependencies. Hence they are not ### +### too much overhead or additional dependencies. Hence they are not ### ### included as imports. ### -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// -# function pointLabel was taken from package maptools. maptools is not imported -# or mentioned in DESCRIPTION to reduce dependencies as maptools requires sp and +# function pointLabel was taken from package maptools. maptools is not imported +# or mentioned in DESCRIPTION to reduce dependencies as maptools requires sp and # gpclib. Thus below is the exact maptools:::pointLabel code. # -pointLabel <- function (x, y = NULL, labels = seq(along = x), cex = 1, - method = c("SANN", "GA"), allowSmallOverlap = FALSE, - trace = FALSE, doPlot = TRUE, ...) -{ - if (!missing(y) && (is.character(y) || is.expression(y))) { - labels <- y - y <- NULL +pointLabel <- function(x, y = NULL, labels = seq(along = x), cex = 1, + method = c("SANN", "GA"), allowSmallOverlap = FALSE, + trace = FALSE, doPlot = TRUE, ...) { + if (!missing(y) && (is.character(y) || is.expression(y))) { + labels <- y + y <- NULL + } + labels <- as.graphicsAnnot(labels) + boundary <- par()$usr + xyAspect <- par()$pin[1] / par()$pin[2] + toUnityCoords <- function(xy) { + list(x = (xy$x - boundary[1]) / (boundary[2] - boundary[1]) * + xyAspect, y = (xy$y - boundary[3]) / (boundary[4] - + boundary[3]) / xyAspect) + } + toUserCoords <- function(xy) { + list(x = boundary[1] + xy$x / xyAspect * (boundary[2] - + boundary[1]), y = boundary[3] + xy$y * xyAspect * + (boundary[4] - boundary[3])) + } + z <- xy.coords(x, y, recycle = TRUE) + z <- toUnityCoords(z) + x <- z$x + y <- z$y + if (length(labels) < length(x)) { + labels <- rep(labels, length(x)) + } + method <- match.arg(method) + if (allowSmallOverlap) { + nudgeFactor <- 0.02 + } + n_labels <- length(x) + width <- (strwidth(labels, units = "figure", cex = cex) + + 0.015) * xyAspect + height <- (strheight(labels, units = "figure", cex = cex) + + 0.015) / xyAspect + gen_offset <- function(code) { + c(-1, -1, -1, 0, 0, 1, 1, 1)[code] * + (width / 2) + (0 + 1i) * c(-1, 0, 1, -1, 1, -1, 0, 1)[code] * + (height / 2) + } + rect_intersect <- function(xy1, offset1, xy2, offset2) { + w <- pmin(Re(xy1 + offset1 / 2), Re(xy2 + offset2 / 2)) - + pmax(Re(xy1 - offset1 / 2), Re(xy2 - offset2 / 2)) + h <- pmin(Im(xy1 + offset1 / 2), Im(xy2 + offset2 / 2)) - + pmax(Im(xy1 - offset1 / 2), Im(xy2 - offset2 / 2)) + w[w <= 0] <- 0 + h[h <= 0] <- 0 + w * h + } + nudge <- function(offset) { + doesIntersect <- rect_intersect( + xy[rectidx1] + offset[rectidx1], + rectv[rectidx1], xy[rectidx2] + offset[rectidx2], + rectv[rectidx2] + ) > 0 + pyth <- abs(xy[rectidx1] + offset[rectidx1] - xy[rectidx2] - + offset[rectidx2]) / nudgeFactor + eps <- 1e-10 + for (i in which(doesIntersect & pyth > eps)) { + idx1 <- rectidx1[i] + idx2 <- rectidx2[i] + vect <- (xy[idx1] + offset[idx1] - xy[idx2] - offset[idx2]) / pyth[idx1] + offset[idx1] <- offset[idx1] + vect + offset[idx2] <- offset[idx2] - vect } - labels <- as.graphicsAnnot(labels) - boundary <- par()$usr - xyAspect <- par()$pin[1]/par()$pin[2] - toUnityCoords <- function(xy) { - list(x = (xy$x - boundary[1])/(boundary[2] - boundary[1]) * - xyAspect, y = (xy$y - boundary[3])/(boundary[4] - - boundary[3])/xyAspect) + offset + } + objective <- function(gene) { + offset <- gen_offset(gene) + if (allowSmallOverlap) { + offset <- nudge(offset) } - toUserCoords <- function(xy) { - list(x = boundary[1] + xy$x/xyAspect * (boundary[2] - - boundary[1]), y = boundary[3] + xy$y * xyAspect * - (boundary[4] - boundary[3])) + if (!is.null(rectidx1)) { + area <- sum(rect_intersect( + xy[rectidx1] + offset[rectidx1], + rectv[rectidx1], xy[rectidx2] + offset[rectidx2], + rectv[rectidx2] + )) + } else { + area <- 0 } - z <- xy.coords(x, y, recycle = TRUE) - z <- toUnityCoords(z) - x <- z$x - y <- z$y - if (length(labels) < length(x)) - labels <- rep(labels, length(x)) - method <- match.arg(method) - if (allowSmallOverlap) - nudgeFactor <- 0.02 - n_labels <- length(x) - width <- (strwidth(labels, units = "figure", cex = cex) + - 0.015) * xyAspect - height <- (strheight(labels, units = "figure", cex = cex) + - 0.015)/xyAspect - gen_offset <- function(code) c(-1, -1, -1, 0, 0, 1, 1, 1)[code] * - (width/2) + (0+1i) * c(-1, 0, 1, -1, 1, -1, 0, 1)[code] * - (height/2) - rect_intersect <- function(xy1, offset1, xy2, offset2) { - w <- pmin(Re(xy1 + offset1/2), Re(xy2 + offset2/2)) - - pmax(Re(xy1 - offset1/2), Re(xy2 - offset2/2)) - h <- pmin(Im(xy1 + offset1/2), Im(xy2 + offset2/2)) - - pmax(Im(xy1 - offset1/2), Im(xy2 - offset2/2)) - w[w <= 0] <- 0 - h[h <= 0] <- 0 - w * h + n_outside <- sum(Re(xy + offset - rectv / 2) < 0 | Re(xy + + offset + rectv / 2) > xyAspect | Im(xy + offset - rectv / 2) < + 0 | Im(xy + offset + rectv / 2) > 1 / xyAspect) + res <- 1000 * area + n_outside + res + } + xy <- x + (0 + 1i) * y + rectv <- width + (0 + 1i) * height + rectidx1 <- rectidx2 <- array(0, (length(x)^2 - length(x)) / 2) + k <- 0 + for (i in 1:length(x)) { + for (j in seq(len = (i - 1))) { + k <- k + 1 + rectidx1[k] <- i + rectidx2[k] <- j } - nudge <- function(offset) { - doesIntersect <- rect_intersect(xy[rectidx1] + offset[rectidx1], - rectv[rectidx1], xy[rectidx2] + offset[rectidx2], - rectv[rectidx2]) > 0 - pyth <- abs(xy[rectidx1] + offset[rectidx1] - xy[rectidx2] - - offset[rectidx2])/nudgeFactor - eps <- 1e-10 - for (i in which(doesIntersect & pyth > eps)) { - idx1 <- rectidx1[i] - idx2 <- rectidx2[i] - vect <- (xy[idx1] + offset[idx1] - xy[idx2] - offset[idx2])/pyth[idx1] - offset[idx1] <- offset[idx1] + vect - offset[idx2] <- offset[idx2] - vect + } + canIntersect <- rect_intersect( + xy[rectidx1], 2 * rectv[rectidx1], + xy[rectidx2], 2 * rectv[rectidx2] + ) > 0 + rectidx1 <- rectidx1[canIntersect] + rectidx2 <- rectidx2[canIntersect] + if (trace) { + cat("possible intersects =", length(rectidx1), "\n") + } + if (trace) { + cat("portion covered =", sum(rect_intersect( + xy, rectv, + xy, rectv + )), "\n") + } + GA <- function() { + n_startgenes <- 1000 + n_bestgenes <- 30 + prob <- 0.2 + mutate <- function(gene) { + offset <- gen_offset(gene) + doesIntersect <- rect_intersect( + xy[rectidx1] + offset[rectidx1], + rectv[rectidx1], xy[rectidx2] + offset[rectidx2], + rectv[rectidx2] + ) > 0 + for (i in which(doesIntersect)) { + gene[rectidx1[i]] <- sample(1:8, 1) + } + for (i in seq(along = gene)) { + if (runif(1) <= prob) { + gene[i] <- sample(1:8, 1) } - offset + } + gene } - objective <- function(gene) { - offset <- gen_offset(gene) - if (allowSmallOverlap) - offset <- nudge(offset) - if (!is.null(rectidx1)) - area <- sum(rect_intersect(xy[rectidx1] + offset[rectidx1], - rectv[rectidx1], xy[rectidx2] + offset[rectidx2], - rectv[rectidx2])) - else area <- 0 - n_outside <- sum(Re(xy + offset - rectv/2) < 0 | Re(xy + - offset + rectv/2) > xyAspect | Im(xy + offset - rectv/2) < - 0 | Im(xy + offset + rectv/2) > 1/xyAspect) - res <- 1000 * area + n_outside - res + crossbreed <- function(g1, g2) { + ifelse(sample(c(0, 1), + length(g1), + replace = TRUE + ) > 0.5, g1, g2) } - xy <- x + (0+1i) * y - rectv <- width + (0+1i) * height - rectidx1 <- rectidx2 <- array(0, (length(x)^2 - length(x))/2) - k <- 0 - for (i in 1:length(x)) for (j in seq(len = (i - 1))) { - k <- k + 1 - rectidx1[k] <- i - rectidx2[k] <- j - } - canIntersect <- rect_intersect(xy[rectidx1], 2 * rectv[rectidx1], - xy[rectidx2], 2 * rectv[rectidx2]) > 0 - rectidx1 <- rectidx1[canIntersect] - rectidx2 <- rectidx2[canIntersect] - if (trace) - cat("possible intersects =", length(rectidx1), "\n") - if (trace) - cat("portion covered =", sum(rect_intersect(xy, rectv, - xy, rectv)), "\n") - GA <- function() { - n_startgenes <- 1000 - n_bestgenes <- 30 - prob <- 0.2 - mutate <- function(gene) { - offset <- gen_offset(gene) - doesIntersect <- rect_intersect(xy[rectidx1] + offset[rectidx1], - rectv[rectidx1], xy[rectidx2] + offset[rectidx2], - rectv[rectidx2]) > 0 - for (i in which(doesIntersect)) { - gene[rectidx1[i]] <- sample(1:8, 1) - } - for (i in seq(along = gene)) if (runif(1) <= prob) - gene[i] <- sample(1:8, 1) - gene + genes <- matrix(sample(1:8, n_labels * n_startgenes, + replace = TRUE + ), n_startgenes, n_labels) + for (i in 1:10) { + scores <- array(0, NROW(genes)) + for (j in 1:NROW(genes)) scores[j] <- objective(genes[j, ]) + rankings <- order(scores) + genes <- genes[rankings, ] + bestgenes <- genes[1:n_bestgenes, ] + bestscore <- scores[rankings][1] + if (bestscore == 0) { + if (trace) { + cat("overlap area =", bestscore, "\n") } - crossbreed <- function(g1, g2) ifelse(sample(c(0, 1), - length(g1), replace = TRUE) > 0.5, g1, g2) - genes <- matrix(sample(1:8, n_labels * n_startgenes, - replace = TRUE), n_startgenes, n_labels) - for (i in 1:10) { - scores <- array(0, NROW(genes)) - for (j in 1:NROW(genes)) scores[j] <- objective(genes[j, - ]) - rankings <- order(scores) - genes <- genes[rankings, ] - bestgenes <- genes[1:n_bestgenes, ] - bestscore <- scores[rankings][1] - if (bestscore == 0) { - if (trace) - cat("overlap area =", bestscore, "\n") - break - } - genes <- matrix(0, n_bestgenes^2, n_labels) - for (j in 1:n_bestgenes) for (k in 1:n_bestgenes) genes[n_bestgenes * - (j - 1) + k, ] <- mutate(crossbreed(bestgenes[j, - ], bestgenes[k, ])) - genes <- rbind(bestgenes, genes) - if (trace) - cat("overlap area =", bestscore, "\n") + break + } + genes <- matrix(0, n_bestgenes^2, n_labels) + for (j in 1:n_bestgenes) { + for (k in 1:n_bestgenes) { + genes[n_bestgenes * + (j - 1) + k, ] <- mutate(crossbreed(bestgenes[j, ], bestgenes[k, ])) } - nx <- Re(xy + gen_offset(bestgenes[1, ])) - ny <- Im(xy + gen_offset(bestgenes[1, ])) - list(x = nx, y = ny) + } + genes <- rbind(bestgenes, genes) + if (trace) { + cat("overlap area =", bestscore, "\n") + } } - SANN <- function() { - gene <- rep(8, n_labels) - score <- objective(gene) - bestgene <- gene - bestscore <- score - T <- 2.5 - for (i in 1:50) { - k <- 1 - for (j in 1:50) { - newgene <- gene - newgene[sample(1:n_labels, 1)] <- sample(1:8, - 1) - newscore <- objective(newgene) - if (newscore <= score || runif(1) < exp((score - - newscore)/T)) { - k <- k + 1 - score <- newscore - gene <- newgene - } - if (score <= bestscore) { - bestscore <- score - bestgene <- gene - } - if (bestscore == 0 || k == 10) - break - } - if (bestscore == 0) - break - if (trace) - cat("overlap area =", bestscore, "\n") - T <- 0.9 * T + nx <- Re(xy + gen_offset(bestgenes[1, ])) + ny <- Im(xy + gen_offset(bestgenes[1, ])) + list(x = nx, y = ny) + } + SANN <- function() { + gene <- rep(8, n_labels) + score <- objective(gene) + bestgene <- gene + bestscore <- score + T <- 2.5 + for (i in 1:50) { + k <- 1 + for (j in 1:50) { + newgene <- gene + newgene[sample(1:n_labels, 1)] <- sample( + 1:8, + 1 + ) + newscore <- objective(newgene) + if (newscore <= score || runif(1) < exp((score - + newscore) / T)) { + k <- k + 1 + score <- newscore + gene <- newgene } - if (trace) - cat("overlap area =", bestscore, "\n") - nx <- Re(xy + gen_offset(bestgene)) - ny <- Im(xy + gen_offset(bestgene)) - list(x = nx, y = ny) + if (score <= bestscore) { + bestscore <- score + bestgene <- gene + } + if (bestscore == 0 || k == 10) { + break + } + } + if (bestscore == 0) { + break + } + if (trace) { + cat("overlap area =", bestscore, "\n") + } + T <- 0.9 * T } - if (method == "SANN") - xy <- SANN() - else xy <- GA() - xy <- toUserCoords(xy) - if (doPlot) - text(xy, labels, cex = cex, ...) - invisible(xy) + if (trace) { + cat("overlap area =", bestscore, "\n") + } + nx <- Re(xy + gen_offset(bestgene)) + ny <- Im(xy + gen_offset(bestgene)) + list(x = nx, y = ny) + } + if (method == "SANN") { + xy <- SANN() + } else { + xy <- GA() + } + xy <- toUserCoords(xy) + if (doPlot) { + text(xy, labels, cex = cex, ...) + } + invisible(xy) } # Interleave Rows of data frames or matrices # function from package gdata written by Gregory R. Warnes # # -interleave <- function (..., append.source = TRUE, sep = ": ", drop = FALSE) -{ - sources <- list(...) - sources[sapply(sources, is.null)] <- NULL - sources <- lapply(sources, function(x) if (is.matrix(x) || - is.data.frame(x)) - x - else t(x)) - nrows <- sapply(sources, nrow) - mrows <- max(nrows) - if (any(nrows != mrows & nrows != 1)) - stop("Arguments have differening numbers of rows.") - sources <- lapply(sources, function(x) if (nrow(x) == 1) - x[rep(1, mrows), , drop = drop] - else x) - tmp <- do.call("rbind", sources) - nsources <- length(sources) - indexes <- outer((0:(nsources - 1)) * mrows, 1:mrows, "+") - retval <- tmp[indexes, , drop = drop] - if (append.source && !is.null(names(sources))) - if (!is.null(row.names(tmp))) - row.names(retval) <- paste(format(row.names(retval)), - format(names(sources)), sep = sep) - else row.names(retval) <- rep(names(sources), mrows) - retval +interleave <- function(..., append.source = TRUE, sep = ": ", drop = FALSE) { + sources <- list(...) + sources[sapply(sources, is.null)] <- NULL + sources <- lapply(sources, function(x) { + if (is.matrix(x) || + is.data.frame(x)) { + x + } else { + t(x) + } + }) + nrows <- sapply(sources, nrow) + mrows <- max(nrows) + if (any(nrows != mrows & nrows != 1)) { + stop("Arguments have differening numbers of rows.") + } + sources <- lapply(sources, function(x) { + if (nrow(x) == 1) { + x[rep(1, mrows), , drop = drop] + } else { + x + } + }) + tmp <- do.call("rbind", sources) + nsources <- length(sources) + indexes <- outer((0:(nsources - 1)) * mrows, 1:mrows, "+") + retval <- tmp[indexes, , drop = drop] + if (append.source && !is.null(names(sources))) { + if (!is.null(row.names(tmp))) { + row.names(retval) <- paste(format(row.names(retval)), + format(names(sources)), + sep = sep + ) + } else { + row.names(retval) <- rep(names(sources), mrows) + } + } + retval } # function errbar form Hmisc package by Frank E Harrell Jr. # -errbar <- function (x, y, yplus, yminus, cap = 0.015, main = NULL, sub = NULL, - xlab = as.character(substitute(x)), ylab = if (is.factor(x) || - is.character(x)) "" else as.character(substitute(y)), - add = FALSE, lty = 1, type = "p", ylim = NULL, lwd = 1, pch = 16, - Type = rep(1, length(y)), ...) -{ - if (is.null(ylim)) - ylim <- range(y[Type == 1], yplus[Type == 1], yminus[Type == - 1], na.rm = TRUE) - if (is.factor(x) || is.character(x)) { - x <- as.character(x) - n <- length(x) - t1 <- Type == 1 - t2 <- Type == 2 - n1 <- sum(t1) - n2 <- sum(t2) - omai <- par("mai") - mai <- omai - mai[2] <- max(strwidth(x, "inches")) + 0.25 * TRUE #.R. - par(mai = mai) - on.exit(par(mai = omai)) - plot(NA, NA, xlab = ylab, ylab = "", xlim = ylim, ylim = c(1, - n + 1), axes = FALSE, ...) - axis(1) - w <- if (any(t2)) - n1 + (1:n2) + 1 - else numeric(0) - axis(2, at = c(seq.int(length.out = n1), w), labels = c(x[t1], - x[t2]), las = 1, adj = 1) - points(y[t1], seq.int(length.out = n1), pch = pch, type = type, - ...) - segments(yplus[t1], seq.int(length.out = n1), yminus[t1], - seq.int(length.out = n1), lwd = lwd, lty = lty) - if (any(Type == 2)) { - abline(h = n1 + 1, lty = 2, ...) - offset <- mean(y[t1]) - mean(y[t2]) - if (min(yminus[t2]) < 0 & max(yplus[t2]) > 0) - lines(c(0, 0) + offset, c(n1 + 1, par("usr")[4]), - lty = 2, ...) - points(y[t2] + offset, w, pch = pch, type = type, - ...) - segments(yminus[t2] + offset, w, yplus[t2] + offset, - w, lwd = lwd, lty = lty) - at <- pretty(range(y[t2], yplus[t2], yminus[t2])) - axis(side = 3, at = at + offset, labels = format(round(at, - 6))) - } - return(invisible()) - } - if (add) - points(x, y, pch = pch, type = type, ...) - else plot(x, y, ylim = ylim, xlab = xlab, ylab = ylab, pch = pch, - type = type, ...) - xcoord <- par()$usr[1:2] - smidge <- cap * (xcoord[2] - xcoord[1])/2 - segments(x, yminus, x, yplus, lty = lty, lwd = lwd) - if (par()$xlog) { - xstart <- x * 10^(-smidge) - xend <- x * 10^(smidge) +errbar <- function( + x, y, yplus, yminus, cap = 0.015, main = NULL, sub = NULL, + xlab = as.character(substitute(x)), ylab = if (is.factor(x) || + is.character(x)) { + "" + } else { + as.character(substitute(y)) + }, + add = FALSE, lty = 1, type = "p", ylim = NULL, lwd = 1, pch = 16, + Type = rep(1, length(y)), ...) { + if (is.null(ylim)) { + ylim <- range(y[Type == 1], yplus[Type == 1], yminus[Type == + 1], na.rm = TRUE) + } + if (is.factor(x) || is.character(x)) { + x <- as.character(x) + n <- length(x) + t1 <- Type == 1 + t2 <- Type == 2 + n1 <- sum(t1) + n2 <- sum(t2) + omai <- par("mai") + mai <- omai + mai[2] <- max(strwidth(x, "inches")) + 0.25 * TRUE # .R. + par(mai = mai) + on.exit(par(mai = omai)) + plot(NA, NA, xlab = ylab, ylab = "", xlim = ylim, ylim = c( + 1, + n + 1 + ), axes = FALSE, ...) + axis(1) + w <- if (any(t2)) { + n1 + (1:n2) + 1 + } else { + numeric(0) } - else { - xstart <- x - smidge - xend <- x + smidge + axis(2, at = c(seq.int(length.out = n1), w), labels = c( + x[t1], + x[t2] + ), las = 1, adj = 1) + points(y[t1], seq.int(length.out = n1), + pch = pch, type = type, + ... + ) + segments(yplus[t1], seq.int(length.out = n1), yminus[t1], + seq.int(length.out = n1), + lwd = lwd, lty = lty + ) + if (any(Type == 2)) { + abline(h = n1 + 1, lty = 2, ...) + offset <- mean(y[t1]) - mean(y[t2]) + if (min(yminus[t2]) < 0 & max(yplus[t2]) > 0) { + lines(c(0, 0) + offset, c(n1 + 1, par("usr")[4]), + lty = 2, ... + ) + } + points(y[t2] + offset, w, + pch = pch, type = type, + ... + ) + segments(yminus[t2] + offset, w, yplus[t2] + offset, + w, + lwd = lwd, lty = lty + ) + at <- pretty(range(y[t2], yplus[t2], yminus[t2])) + axis(side = 3, at = at + offset, labels = format(round( + at, + 6 + ))) } - segments(xstart, yminus, xend, yminus, lwd = lwd, lty = lty) - segments(xstart, yplus, xend, yplus, lwd = lwd, lty = lty) return(invisible()) + } + if (add) { + points(x, y, pch = pch, type = type, ...) + } else { + plot(x, y, + ylim = ylim, xlab = xlab, ylab = ylab, pch = pch, + type = type, ... + ) + } + xcoord <- par()$usr[1:2] + smidge <- cap * (xcoord[2] - xcoord[1]) / 2 + segments(x, yminus, x, yplus, lty = lty, lwd = lwd) + if (par()$xlog) { + xstart <- x * 10^(-smidge) + xend <- x * 10^(smidge) + } else { + xstart <- x - smidge + xend <- x + smidge + } + segments(xstart, yminus, xend, yminus, lwd = lwd, lty = lty) + segments(xstart, yplus, xend, yplus, lwd = lwd, lty = lty) + return(invisible()) } ### PMC to Fisher's Z and back from package psych written by William Revelle ### # only needed if psych is removed from COLLATE # -# fisherz <- function (rho) +# fisherz <- function (rho) # { # 0.5 * log((1 + rho)/(1 - rho)) # } -# -# fisherz2r <- function (z) +# +# fisherz2r <- function (z) # { # (exp(2 * z) - 1)/(1 + exp(2 * z)) # } @@ -317,19 +397,19 @@ errbar <- function (x, y, yplus, yminus, cap = 0.015, main = NULL, sub = NULL, -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// ## Optimal Box-Cox transformation according to ## a grid-based maximization of the correlation ## of a Normal P-P plot. -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// ## Author: Ioannis Kosmidis ## Email: ## Latest release: 02/08/2008 ## Distributed under GPL 2 or greater: ## Available at http://www.gnu.org/licenses -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// ## "normal.ppplot" -## +## ## Arguments: ## x: a vector of the observed values ## plot: values TRUE/FALSE depending on whether the Normal P-P @@ -338,62 +418,75 @@ errbar <- function (x, y, yplus, yminus, cap = 0.015, main = NULL, sub = NULL, ## Value: ## Either a Normal P-P plot or the correlation of the Normal ## P-P plot, depending on the values of the plot argument. -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// ## "optimal.boxcox" -## +## ## Arguments: ## x: a vector of the observed values ## lambda: the grid of lambda values that should be considered ## for the grid maximization ## Value: ## A plot showing the Normal P-P plot correlations for the -## grid of values of lambda considered and the Normal P-P plot +## grid of values of lambda considered and the Normal P-P plot ## for the value of lambda which resulted in higher ## correlation. ## The vector of the transformed observations is also ## returned. -#////////////////////////////////////////////////////////////////////////////// - -normal.ppplot <- function(x, plot=FALSE) { - standardized.x <- (x - mean(x))/sd(x) +# ////////////////////////////////////////////////////////////////////////////// + +normal.ppplot <- function(x, plot = FALSE) { + standardized.x <- (x - mean(x)) / sd(x) obs.probs <- pnorm(sort(standardized.x)) theor.probs <- ppoints(length(x)) corrs.pp <- cor(obs.probs, theor.probs) if (plot) { plot(obs.probs, theor.probs, - xlab = "Probabilities based on the standardized observed vector", - ylab = "Theoretical probabilities") - title(main = expression("Normal distribution P-P Plot"), - sub = paste("Normal P-P plot correlation coefficient:", - round(corrs.pp, 3))) - abline(0, 1) + xlab = "Probabilities based on the standardized observed vector", + ylab = "Theoretical probabilities" + ) + title( + main = expression("Normal distribution P-P Plot"), + sub = paste( + "Normal P-P plot correlation coefficient:", + round(corrs.pp, 3) + ) + ) + abline(0, 1) + } else { + corrs.pp } - else corrs.pp } -optimal.boxcox <- function(x, lambda = seq(-2, 2, len=200), plot=FALSE) { +optimal.boxcox <- function(x, lambda = seq(-2, 2, len = 200), plot = FALSE) { ll <- length(lambda) correlations.pp <- numeric(ll) for (j in 1:ll) { - if (lambda[j]==0) temp <- log(x) - else temp <- (x^lambda[j]-1)/lambda[j] + if (lambda[j] == 0) { + temp <- log(x) + } else { + temp <- (x^lambda[j] - 1) / lambda[j] + } correlations.pp[j] <- normal.ppplot(temp, plot = FALSE) } m.ind <- which.max(correlations.pp) lambda.max <- lambda[m.ind] - if (plot){ - par(mfrow = c(1,2)) - plot(lambda, correlations.pp, type='l', - ylim=c(min(correlations.pp), 1.1), - xlab = expression(lambda), - ylab = "Normal P-P plot correlation coefficient") - points(lambda.max, correlations.pp[m.ind], pch="+") - text(lambda.max, correlations.pp[m.ind] + 0.05, - bquote(lambda == .(lambda.max))) + if (plot) { + par(mfrow = c(1, 2)) + plot(lambda, correlations.pp, + type = "l", + ylim = c(min(correlations.pp), 1.1), + xlab = expression(lambda), + ylab = "Normal P-P plot correlation coefficient" + ) + points(lambda.max, correlations.pp[m.ind], pch = "+") + text( + lambda.max, correlations.pp[m.ind] + 0.05, + bquote(lambda == .(lambda.max)) + ) title(expression(paste(lambda, " versus P-P plot correlations"))) } - power.transformed <- (x^lambda.max - 1)/lambda.max + power.transformed <- (x^lambda.max - 1) / lambda.max normal.ppplot(power.transformed, plot = plot) - list(x=power.transformed, lambda=lambda.max) + list(x = power.transformed, lambda = lambda.max) } diff --git a/R/utils.r b/R/utils.r index d0d34161..f983e520 100644 --- a/R/utils.r +++ b/R/utils.r @@ -7,101 +7,104 @@ has_only_0_1_ratings <- function(x) { } -covpop <- function(x, y, na.rm=TRUE){ - x <- unlist(x) - y <- unlist(y) - if (na.rm) { # delete missings +covpop <- function(x, y, na.rm = TRUE) { + x <- unlist(x) + y <- unlist(y) + if (na.rm) { # delete missings index <- is.na(x | is.na(y)) x <- x[!index] y <- y[!index] } - n <- length(x) - ((n-1)/n) * cov(x=x, y=y) # undo Bessel's correction + n <- length(x) + ((n - 1) / n) * cov(x = x, y = y) # undo Bessel's correction } -varpop <- function(x, na.rm=FALSE){ - covpop(x=x, y=x, na.rm=na.rm) # undo Bessel's correction +varpop <- function(x, na.rm = FALSE) { + covpop(x = x, y = x, na.rm = na.rm) # undo Bessel's correction } -sdpop <- function(...){ - sqrt(varpop(...)) +sdpop <- function(...) { + sqrt(varpop(...)) } -# factorial function +# factorial function # wrapper for convenience -fac <- function (x) gamma(1 + x) - -joinString <- function(x) - paste(unlist(x), sep="", collapse=" ") - -trimBlanksInString <- function(x) - sub("^[[:space:]]*(.*?)[[:space:]]*$", "\\1", x, perl=TRUE) - - -baseSplitStringInt <- function(text, availwidth=1, cex=1) # function to split text in base graphics -{ - if (is.expression(text)){ # expressions cannot be split - return(text) - #break - } - if (identical(text, NULL)) text <- "" - if (identical(text, NA)) text <- "" - if (identical(text, character(0))) text <- "" - if (text == ""){ - return(paste(text)) - #break - } - - strings <- strsplit(as.character(text), " ")[[1]] - if (length(strings) == 1){ - return(paste(strings)) - #break - } - newstring <- strings[1] - linewidth <- strwidth(newstring, cex = cex) - gapwidth <- strwidth(" ", cex = cex) - - for (i in 2:length(strings)) { - width <- strwidth(strings[i], cex = cex) - if (linewidth + gapwidth + width < availwidth){ - sep <- " " - linewidth <- linewidth + gapwidth + width - } else { - sep <- "\n" - linewidth <- width - } - newstring <- paste(newstring, strings[i], sep=sep) - } - newstring -} - - -baseSplitString <- function(text, availwidth=1, cex=1){ - as.vector(sapply(text, baseSplitStringInt, - availwidth=availwidth, cex=cex)) -} - - -# makeStandardRangeColorRamp() creates color ramp for supplied colors that takes +fac <- function(x) gamma(1 + x) + +joinString <- function(x) { + paste(unlist(x), sep = "", collapse = " ") +} + +trimBlanksInString <- function(x) { + sub("^[[:space:]]*(.*?)[[:space:]]*$", "\\1", x, perl = TRUE) +} + + +baseSplitStringInt <- function(text, availwidth = 1, cex = 1) # function to split text in base graphics +{ + if (is.expression(text)) { # expressions cannot be split + return(text) + # break + } + if (identical(text, NULL)) text <- "" + if (identical(text, NA)) text <- "" + if (identical(text, character(0))) text <- "" + if (text == "") { + return(paste(text)) + # break + } + + strings <- strsplit(as.character(text), " ")[[1]] + if (length(strings) == 1) { + return(paste(strings)) + # break + } + newstring <- strings[1] + linewidth <- strwidth(newstring, cex = cex) + gapwidth <- strwidth(" ", cex = cex) + + for (i in 2:length(strings)) { + width <- strwidth(strings[i], cex = cex) + if (linewidth + gapwidth + width < availwidth) { + sep <- " " + linewidth <- linewidth + gapwidth + width + } else { + sep <- "\n" + linewidth <- width + } + newstring <- paste(newstring, strings[i], sep = sep) + } + newstring +} + + +baseSplitString <- function(text, availwidth = 1, cex = 1) { + as.vector(sapply(text, baseSplitStringInt, + availwidth = availwidth, cex = cex + )) +} + + +# makeStandardRangeColorRamp() creates color ramp for supplied colors that takes # values between [0,1] and returns a hex color value # -makeStandardRangeColorRamp <- function(colors, na.col="#FFFFFF", ...){ - ramp <- colorRamp(colors, ...) - function(x){ - is.na(x) <- is.na(x) # convert NaN values to NA +makeStandardRangeColorRamp <- function(colors, na.col = "#FFFFFF", ...) { + ramp <- colorRamp(colors, ...) + function(x) { + is.na(x) <- is.na(x) # convert NaN values to NA na.index <- is.na(x) - x[na.index] <- 0 # overwrite so color can be determined - x <- ramp(x) # actual color calculation - col <- rgb(x[, 1], x[, 2], x[, 3], maxColorValue = 255) - col[na.index] <- na.col # replace na indices with default NA color - col - } + x[na.index] <- 0 # overwrite so color can be determined + x <- ramp(x) # actual color calculation + col <- rgb(x[, 1], x[, 2], x[, 3], maxColorValue = 255) + col[na.index] <- na.col # replace na indices with default NA color + col + } } #' modifyListNull -#' +#' #' TODO: a modified version of modifyList that does not overwrite elements #' if they are NULL in the supplied list #' @@ -110,146 +113,156 @@ makeStandardRangeColorRamp <- function(colors, na.col="#FFFFFF", ...){ #' @return list #' @noRd #' -modifyListNull <- function (x, val) -{ - stopifnot(is.list(x), is.list(val)) - xnames <- names(x) - for (v in names(val)) { - x[[v]] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]])) - Recall(x[[v]], val[[v]]) - else if(!is.null(val[[v]])){ # this part was extended to check if element is NULL - val[[v]] - } else x[[v]] +modifyListNull <- function(x, val) { + stopifnot(is.list(x), is.list(val)) + xnames <- names(x) + for (v in names(val)) { + x[[v]] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]])) { + Recall(x[[v]], val[[v]]) + } else if (!is.null(val[[v]])) { # this part was extended to check if element is NULL + val[[v]] + } else { + x[[v]] } - x + } + x } -#l1 <- list(a=1, b=2) -#l2 <- list(a=NULL, b=3) -#modifyListNull(l1, l2) -#modifyList(l1,l2) -#modifyListNull(l2, l1) +# l1 <- list(a=1, b=2) +# l2 <- list(a=NULL, b=3) +# modifyListNull(l1, l2) +# modifyList(l1,l2) +# modifyListNull(l2, l1) #' modifyListNA -#' -#' TODO: a modified version of modifyList that does not overwrite elements +#' +#' TODO: a modified version of modifyList that does not overwrite elements #' if they are NA in the supplied list #' @param x #' @param val #' @return list #' @noRd #' -modifyListNA <- function (x, val) { - stopifnot(is.list(x), is.list(val)) - xnames <- names(x) - for (v in names(val)) { - x[[v]] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]])) { - Recall(x[[v]], val[[v]]) - } else if (!is.na(val[[v]])) { # this part was extended to check if element is NULL - val[[v]] - } else x[[v]] +modifyListNA <- function(x, val) { + stopifnot(is.list(x), is.list(val)) + xnames <- names(x) + for (v in names(val)) { + x[[v]] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]])) { + Recall(x[[v]], val[[v]]) + } else if (!is.na(val[[v]])) { # this part was extended to check if element is NULL + val[[v]] + } else { + x[[v]] } - x + } + x } -#l1 <- list(a=1, b=2) -#l2 <- list(a=NA, b=3) -#modifyListNA(l1, l2) -#modifyList(l1,l2) -#modifyListNA(l2, l1) +# l1 <- list(a=1, b=2) +# l2 <- list(a=NA, b=3) +# modifyListNA(l1, l2) +# modifyList(l1,l2) +# modifyListNA(l2, l1) -#l1 <- list(t=list(a=1, b=2)) -#l2 <- list(t=list(a=NA, b=3)) -#modifyListNA(l1, l2) -#modifyList(l1,l2) -#modifyListNA(l2, l1) +# l1 <- list(t=list(a=1, b=2)) +# l2 <- list(t=list(a=NA, b=3)) +# modifyListNA(l1, l2) +# modifyList(l1,l2) +# modifyListNA(l2, l1) -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// #' bring vector values into ring form #' #' the values of a vector that are outside of a given range are remapped #' to the values of the range. This function is useful for loops over rows and -#' columns of a matrix if the -#' +#' columns of a matrix if the +#' #' @param x vector #' @param upper upper limit of range (lower is one. TODO: maybe extend???) #' @return vector #' @export #' @keywords internal #' @examples \dontrun{ -#' ring(1:10, 3) +#' ring(1:10, 3) #' -#' m <- matrix(1:12, ncol=4) -#' for(i in 1:12) -#' print(m[ring(i, 3), map(i, 4)]) +#' m <- matrix(1:12, ncol = 4) +#' for (i in 1:12) { +#' print(m[ring(i, 3), map(i, 4)]) +#' } #' } #' -ring <- function(x, upper){ +ring <- function(x, upper) { res <- x %% upper res[res == 0] <- upper res } -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// #' map a value onto others -#' +#' #' @param x vector #' @param each number of cuts #' @return vector #' @export #' @keywords internal #' @examples \dontrun{ -#' map(1:10, 3) +#' map(1:10, 3) #' -#' m <- matrix(1:12, ncol=4) -#' for(i in 1:12) -#' print(m[ring(i, 3), map(i, 4)]) +#' m <- matrix(1:12, ncol = 4) +#' for (i in 1:12) { +#' print(m[ring(i, 3), map(i, 4)]) +#' } #' } #' -map <- function(x, each){ - ceiling(x/each) +map <- function(x, each) { + ceiling(x / each) } -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// #' order one vector by another #' #' small wrapper to order one vector by another, hardly worth a function -#' +#' #' @param x vector #' @param y vector #' @return vector #' @export #' @keywords internal -orderBy <- function(x,y) y[order(x)] +orderBy <- function(x, y) y[order(x)] -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// #' make ascending and descending vector #' #' along a given length n make ascending indices until reaching #' the midpoint and descend afterwards again. -#' +#' #' @param n `integer` The length of the indexes -#' @param type (integer, default=1). If 1 the cascade index is returned. +#' @param type (integer, default=1). If 1 the cascade index is returned. #' 2 returns the index of left and right side, 3 returns the length #' of the left and right index vector #' @return vector (type 1 or 3) or list (type 2) #' @export #' @keywords internal #' @examples \dontrun{ -#' for(n in 1:10) -#' print(cascade(n)) +#' for (n in 1:10) { +#' print(cascade(n)) +#' } #' } -cascade <- function(n, type=1){ - if (type == 2){ - list( left=(1:n)[0:floor(n/2)], - right=rev((n:1)[0:ceiling(n/2)]) ) - } else if (type == 3){ - c( left=length((1:n)[0:floor(n/2)]), - right=length((n:1)[0:ceiling(n/2)]) ) +cascade <- function(n, type = 1) { + if (type == 2) { + list( + left = (1:n)[0:floor(n / 2)], + right = rev((n:1)[0:ceiling(n / 2)]) + ) + } else if (type == 3) { + c( + left = length((1:n)[0:floor(n / 2)]), + right = length((n:1)[0:ceiling(n / 2)]) + ) } else { - c((1:n)[0:floor(n/2)], rev((1:n)[0:ceiling(n/2)])) + c((1:n)[0:floor(n / 2)], rev((1:n)[0:ceiling(n / 2)])) } } @@ -259,42 +272,43 @@ cascade <- function(n, type=1){ # index.insert Index der Stellen an denen ein Objekt eingefügt werden soll # # 1 2 3 4 1 2 3 4 -#1 3 1 5 +# 1 3 1 5 # 2 3 4 5 # 1 4 # 2 3 5 6 # 1 4 #' insertAt -#' -#' TODO: a modified version of modifyList that does not overwrite elements +#' +#' TODO: a modified version of modifyList that does not overwrite elements #' if they are NA in the supplied list #' @param x #' @param val #' @return list #' @noRd -insertAt <- function(index.base, index.insert, side="pre"){ - if(!side %in% c("pre", "post")) # Integrity Checks - stop("side must be a a string. It can take the values 'pre' or 'post'") - res <- list(index.base=index.base, index.insert=index.insert) - for(i in seq_along(index.insert)){ - at <- index.insert[i] - if(side=="pre"){ # VOR der benannten Position at einfügen - index.base <- index.base + (index.base >= at) # Alle Indizes größer-gleich at werden um eines erhöht - options(warn=-1) # in case index.base=numeric(0) warnings gets generated at max() - index.insert <- index.insert + ((index.insert > at) & - any(index.insert[seq_along(index.insert) > i] <= max(index.base))) - options(warn=0) - } - if(side=="post"){ # NACH der benannten Position at einfügen - index.base <- index.base + (index.base > at) # Alle Indizes größer als at werden um eines erhöht - options(warn=-1) # in case index.base=numeric(0) warnings gets generated at max() - index.insert <- index.insert + ((index.insert >= at) & - any(index.insert[seq_along(index.insert) >= i] <= max(index.base))) - options(warn=0) - } - } - c(res, list(index.base.new=index.base, index.insert.new=index.insert)) +insertAt <- function(index.base, index.insert, side = "pre") { + if (!side %in% c("pre", "post")) { # Integrity Checks + stop("side must be a a string. It can take the values 'pre' or 'post'") + } + res <- list(index.base = index.base, index.insert = index.insert) + for (i in seq_along(index.insert)) { + at <- index.insert[i] + if (side == "pre") { # VOR der benannten Position at einfügen + index.base <- index.base + (index.base >= at) # Alle Indizes größer-gleich at werden um eines erhöht + options(warn = -1) # in case index.base=numeric(0) warnings gets generated at max() + index.insert <- index.insert + ((index.insert > at) & + any(index.insert[seq_along(index.insert) > i] <= max(index.base))) + options(warn = 0) + } + if (side == "post") { # NACH der benannten Position at einfügen + index.base <- index.base + (index.base > at) # Alle Indizes größer als at werden um eines erhöht + options(warn = -1) # in case index.base=numeric(0) warnings gets generated at max() + index.insert <- index.insert + ((index.insert >= at) & + any(index.insert[seq_along(index.insert) >= i] <= max(index.base))) + options(warn = 0) + } + } + c(res, list(index.base.new = index.base, index.insert.new = index.insert)) } @@ -336,7 +350,7 @@ insertAt <- function(index.base, index.insert, side="pre"){ #' apply with a progress bar #' -#' Can be used like standard base:::apply. The only thing +#' Can be used like standard base:::apply. The only thing #' it does is create an additional progress bar. #' #' @param X see ?apply for parameter explanation @@ -349,36 +363,34 @@ insertAt <- function(index.base, index.insert, side="pre"){ #' @keywords internal #' @examples \dontrun{ #' -#' apply_pb(anscombe, 2, sd, na.rm=TRUE) +#' apply_pb(anscombe, 2, sd, na.rm = TRUE) #' -#' # larger dataset -#' df <- data.frame(rnorm(30000), rnorm(30000)) -#' head(apply_pb(df, 1, sd)) -#' -#' # performance comparison -#' df <- data.frame(rnorm(90000), rnorm(90000)) -#' system.time(apply(df, 1, sd)) -#' system.time(apply_pb(df, 1, sd)) +#' # larger dataset +#' df <- data.frame(rnorm(30000), rnorm(30000)) +#' head(apply_pb(df, 1, sd)) #' +#' # performance comparison +#' df <- data.frame(rnorm(90000), rnorm(90000)) +#' system.time(apply(df, 1, sd)) +#' system.time(apply_pb(df, 1, sd)) #' } #' -apply_pb <- function(X, MARGIN, FUN, ...) -{ - env <- environment() # this environment - pb_Total <- sum(dim(X)[MARGIN]) # get mex value for progress bar - counter <- 0 # make counter variable - pb <- txtProgressBar(min = 0, max = pb_Total, style = 3) # make progress bar - - # wrapper around FUN - wrapper <- function(...){ - curVal <- get("counter", envir = env) # get counter value - assign("counter", curVal +1 ,envir= env) # and increment it by one - setTxtProgressBar(get("pb", envir= env), curVal +1) # update progress bar - FUN(...) - } - res <- apply(X, MARGIN, wrapper, ...) # apply wrapper with apply - close(pb) # close progress bar - res +apply_pb <- function(X, MARGIN, FUN, ...) { + env <- environment() # this environment + pb_Total <- sum(dim(X)[MARGIN]) # get mex value for progress bar + counter <- 0 # make counter variable + pb <- txtProgressBar(min = 0, max = pb_Total, style = 3) # make progress bar + + # wrapper around FUN + wrapper <- function(...) { + curVal <- get("counter", envir = env) # get counter value + assign("counter", curVal + 1, envir = env) # and increment it by one + setTxtProgressBar(get("pb", envir = env), curVal + 1) # update progress bar + FUN(...) + } + res <- apply(X, MARGIN, wrapper, ...) # apply wrapper with apply + close(pb) # close progress bar + res } # apply_pb(anscombe, 2, sd, na.rm=TRUE) @@ -391,40 +403,38 @@ apply_pb <- function(X, MARGIN, FUN, ...) #' lapply with a progress bar #' -#' Can be used like standard base:::lapply. The only thing +#' Can be used like standard base:::lapply. The only thing #' it does is create an additional progress bar. #' #' @param X see ?lapply for parameter explanation -#' @param FUN see ?lapply -#' @param ... see ?lapply +#' @param FUN see ?lapply +#' @param ... see ?lapply #' @return list see ?lapply #' @seealso [lapply()] #' @export #' @keywords internal #' @examples \dontrun{ #' -#' l <- sapply(1:20000, function(x) list(rnorm(1000))) -#' lapply_pb(l, mean) -#' +#' l <- sapply(1:20000, function(x) list(rnorm(1000))) +#' lapply_pb(l, mean) #' } #' -lapply_pb <- function(X, FUN, ...) -{ - env <- environment() # this environment - pb_Total <- length(X) # get max value for progress bar - counter <- 0 # make counter variable - pb <- txtProgressBar(min = 0, max = pb_Total, style = 3) # make progress bar - - # wrapper around FUN - wrapper <- function(...){ - curVal <- get("counter", envir = env) # get counter value - assign("counter", curVal +1 ,envir=env) # and increment it by one - setTxtProgressBar(get("pb", envir=env), curVal +1) # update progress bar - FUN(...) - } - res <- lapply(X, wrapper, ...) # use wrapper with lapply - close(pb) # close progress bar - res +lapply_pb <- function(X, FUN, ...) { + env <- environment() # this environment + pb_Total <- length(X) # get max value for progress bar + counter <- 0 # make counter variable + pb <- txtProgressBar(min = 0, max = pb_Total, style = 3) # make progress bar + + # wrapper around FUN + wrapper <- function(...) { + curVal <- get("counter", envir = env) # get counter value + assign("counter", curVal + 1, envir = env) # and increment it by one + setTxtProgressBar(get("pb", envir = env), curVal + 1) # update progress bar + FUN(...) + } + res <- lapply(X, wrapper, ...) # use wrapper with lapply + close(pb) # close progress bar + res } # l <- lapply(1:20000, function(x) list(rnorm(1000))) @@ -434,49 +444,47 @@ lapply_pb <- function(X, FUN, ...) #' sapply with a progress bar #' -#' Can be used like standard base:::sapply. The only thing +#' Can be used like standard base:::sapply. The only thing #' it does is create an additional progress bar. #' #' @param X see ?sapply for parameter explanation -#' @param FUN see ?sapply -#' @param ... see ?sapply +#' @param FUN see ?sapply +#' @param ... see ?sapply #' @return list see ?sapply #' @seealso [sapply()] #' @export #' @keywords internal #' @examples \dontrun{ #' -#' l <- sapply(1:20000, function(x) list(rnorm(1000))) -#' head(sapply_pb(l, mean)) -#' -#' # performance comparison -#' l <- sapply(1:20000, function(x) list(rnorm(1000))) -#' system.time(sapply(l, mean)) -#' system.time(sapply_pb(l, mean)) +#' l <- sapply(1:20000, function(x) list(rnorm(1000))) +#' head(sapply_pb(l, mean)) #' +#' # performance comparison +#' l <- sapply(1:20000, function(x) list(rnorm(1000))) +#' system.time(sapply(l, mean)) +#' system.time(sapply_pb(l, mean)) #' } -sapply_pb <- function(X, FUN, ...) -{ - env <- environment() # this environment - pb_Total <- length(X) # get max value for progress bar - counter <- 0 # make counter variable - pb <- txtProgressBar(min = 0, max = pb_Total, style = 3) # make progress bar - - # wrapper around FUN - wrapper <- function(...){ - curVal <- get("counter", envir = env) # get counter value - assign("counter", curVal +1 ,envir=env) # and increment it by one - setTxtProgressBar(get("pb", envir=env), curVal +1) # update progress bar - FUN(...) - } - res <- sapply(X, wrapper, ...) # use wrapper with sapply - close(pb) # close progress bar - res +sapply_pb <- function(X, FUN, ...) { + env <- environment() # this environment + pb_Total <- length(X) # get max value for progress bar + counter <- 0 # make counter variable + pb <- txtProgressBar(min = 0, max = pb_Total, style = 3) # make progress bar + + # wrapper around FUN + wrapper <- function(...) { + curVal <- get("counter", envir = env) # get counter value + assign("counter", curVal + 1, envir = env) # and increment it by one + setTxtProgressBar(get("pb", envir = env), curVal + 1) # update progress bar + FUN(...) + } + res <- sapply(X, wrapper, ...) # use wrapper with sapply + close(pb) # close progress bar + res } #' reverse a string -#' +#' #' reverses the strings of a vector, i.e. c("ABC", "abc") #' becomes c("CBA", "cba") #' @@ -487,19 +495,21 @@ sapply_pb <- function(X, FUN, ...) #' @examples #' strReverse(c("ABC", "abc")) strReverse <- function(x) { - sapply(lapply(strsplit(x, NULL), rev), - paste, collapse="") + sapply(lapply(strsplit(x, NULL), rev), + paste, + collapse = "" + ) } -#' trim vector to lower or upper value +#' trim vector to lower or upper value #' -#' the range a value may take is restricted to by an upper and +#' the range a value may take is restricted to by an upper and #' lower boundary. If it exceeds the boundary the value is replaced #' by the boundary value or alternatively by NA #' #' @param x numeric vector -#' @param minmax minimal and maximal possible value (default c(-Inf, Inf) +#' @param minmax minimal and maximal possible value (default c(-Inf, Inf) #' i.e. no trimming occurs) #' @param na Use NAs for replacing values that are out of range #' @return vector vector whose elements that are out of range are replaced @@ -507,16 +517,15 @@ strReverse <- function(x) { #' @keywords internal #' @examples #' trim_val(30) -#' trim_val(30, c(10,20)) +#' trim_val(30, c(10, 20)) #' -trim_val <- function(x, minmax=c(-Inf, Inf), na=FALSE){ - if(na){ +trim_val <- function(x, minmax = c(-Inf, Inf), na = FALSE) { + if (na) { x[x < minmax[1]] <- NA x[x > minmax[2]] <- NA - } - else { + } else { x[x < minmax[1]] <- minmax[1] - x[x > minmax[2]] <- minmax[2] + x[x > minmax[2]] <- minmax[2] } x } @@ -527,116 +536,123 @@ trim_val <- function(x, minmax=c(-Inf, Inf), na=FALSE){ #' recycle vector to given length #' #' @param vec vector to be recycled -#' @param length integer or vector. integer determines length of -#' recycling. If a vector is provided the length of the +#' @param length integer or vector. integer determines length of +#' recycling. If a vector is provided the length of the #' vector is used. #' @param na.fill Use NAs for filling up to given length (default=FALSE) #' @return vector #' @note If 2nd argument is a vector, the first argument is recycled -#' to the length of the second vector. Instead of recycling the vector can -#' also be added extra NAs if the length argument is smaller than the -#' number of elements from vec, vec is cut off to make it usable for +#' to the length of the second vector. Instead of recycling the vector can +#' also be added extra NAs if the length argument is smaller than the +#' number of elements from vec, vec is cut off to make it usable for #' many purposes. -#' +#' #' @export #' @keywords internal #' @examples -#' recycle(c(1,2,3), 7) -#' recycle(c(1,2,3), letters[1:7]) -#' recycle(c(1,2,3), 7, na.fill=TRUE) -#' recycle(1, letters[1:3], na.fill=TRUE) +#' recycle(c(1, 2, 3), 7) +#' recycle(c(1, 2, 3), letters[1:7]) +#' recycle(c(1, 2, 3), 7, na.fill = TRUE) +#' recycle(1, letters[1:3], na.fill = TRUE) #' recycle(letters[1:3], 7) -#' recycle(letters[1:3], letters[1:7]) -#' recycle(letters[1:40], letters[1:7]) # vec is cut off -recycle <- function(vec, length, na.fill=FALSE){ - if (!is.vector(vec) & !is.vector(length)) - stop("vec and length must be vectors. length may also be an integer") - if (!is.numeric(length) & is.vector(length)) # both vectors - length <- length(length) - if (is.vector(length) & length(length) > 1L) # is length a vector longer than 1 - length <- length(length) # then get length of vector - if (!na.fill) { - newvec <- rep(vec, ceiling(length / length(vec))) # enlarge vector by recycling - } else { - newvec <- c(vec, rep(NA, length * - (ceiling(length / length(vec)) - 1L))) # fill up with NAs - } - newvec[1L:length] -} - - - -#' variation of recycle that recycles one vector x or y to the length of the +#' recycle(letters[1:3], letters[1:7]) +#' recycle(letters[1:40], letters[1:7]) # vec is cut off +recycle <- function(vec, length, na.fill = FALSE) { + if (!is.vector(vec) & !is.vector(length)) { + stop("vec and length must be vectors. length may also be an integer") + } + if (!is.numeric(length) & is.vector(length)) { # both vectors + length <- length(length) + } + if (is.vector(length) & length(length) > 1L) { # is length a vector longer than 1 + length <- length(length) + } # then get length of vector + if (!na.fill) { + newvec <- rep(vec, ceiling(length / length(vec))) # enlarge vector by recycling + } else { + newvec <- c(vec, rep(NA, length * + (ceiling(length / length(vec)) - 1L))) # fill up with NAs + } + newvec[1L:length] +} + + + +#' variation of recycle that recycles one vector x or y to the length of the #' longer one #' #' #' @param x vector to be recycled if shorter than y #' @param y vector to be recycled if shorter than x #' @param na.fill Use NAs for filling up to given length (default=FALSE) -#' @return list a list containing the recycled x vector as first and -#' the recycled y vector as second element +#' @return list a list containing the recycled x vector as first and +#' the recycled y vector as second element #' @export #' @keywords internal #' @examples #' recycle2(1:10, 1:3) #' recycle2(1, 1:5) -#' recycle2(1, 1:5, na.fill=TRUE) -#' recycle2(1:5, 5:1) # vectors unchanged -recycle2 <- function(x, y, na.fill=FALSE){ +#' recycle2(1, 1:5, na.fill = TRUE) +#' recycle2(1:5, 5:1) # vectors unchanged +recycle2 <- function(x, y, na.fill = FALSE) { len.x <- length(x) len.y <- length(y) - if(len.x < len.y) - x <- recycle(x, len.y, na.fill) - else if (len.x > len.y) + if (len.x < len.y) { + x <- recycle(x, len.y, na.fill) + } else if (len.x > len.y) { y <- recycle(y, len.x, na.fill) - list(x=x,y=y) + } + list(x = x, y = y) } #' generate a random words -#' -#' randomWords generates a vector of random words taken from a small +#' +#' randomWords generates a vector of random words taken from a small #' set of words #' @param n number of words to be generated (integer) #' @return a string with n words (if length is not constrained) #' @export #' @keywords internal #' @examples -#' randomWords(10) # 10 random words -randomWords <- function(n){ - if (! is.numeric(n)) - stop("n must be an integer") - words <- c( "the", "novel", "depicts", "Harry", "as", "an", "essentially", - "good", "man", "who", "is", "forced", "into", "blackmarket", - "activity", "by", "economic", "forces", "beyond", "his", - "control", "initially", "his", "fishing", "charter", - "customer", "Mr.", "Johnson", "tricks", "Mark", "by", - "slipping", "away", "without", "paying", "any", "of", "the", - "money", "he", "owes", "him", "Brownstone", "then", "flees", - "back", "to", "the", "mainland", "by", "airplane", "before", - "he", "realizes", "what", "has", "happened", "I", "she") - sample(words, n, replace=TRUE) +#' randomWords(10) # 10 random words +randomWords <- function(n) { + if (!is.numeric(n)) { + stop("n must be an integer") + } + words <- c( + "the", "novel", "depicts", "Harry", "as", "an", "essentially", + "good", "man", "who", "is", "forced", "into", "blackmarket", + "activity", "by", "economic", "forces", "beyond", "his", + "control", "initially", "his", "fishing", "charter", + "customer", "Mr.", "Johnson", "tricks", "Mark", "by", + "slipping", "away", "without", "paying", "any", "of", "the", + "money", "he", "owes", "him", "Brownstone", "then", "flees", + "back", "to", "the", "mainland", "by", "airplane", "before", + "he", "realizes", "what", "has", "happened", "I", "she" + ) + sample(words, n, replace = TRUE) } #' generate a random sentence with n words #' #' @param n number of word in sentence -#' @param maxchar maximal number of characters per sentence. Note that whole -#' words (not part of words) are excluded if the maximal number +#' @param maxchar maximal number of characters per sentence. Note that whole +#' words (not part of words) are excluded if the maximal number #' is exceeded. #' @return a string with n words (if length is not constrained) #' @export #' @keywords internal -#' @examples -#' randomSentence(10) # one random sentence with 10 words -randomSentence <- function(n, maxchar=Inf){ - x <- paste(randomWords(n), collapse=" ") - x.split <- strsplit(x, " ")[[1]] - chars <- as.vector(sapply(x.split, nchar)) - paste(unlist(x.split[cumsum(chars) < maxchar]), collapse = " ") +#' @examples +#' randomSentence(10) # one random sentence with 10 words +randomSentence <- function(n, maxchar = Inf) { + x <- paste(randomWords(n), collapse = " ") + x.split <- strsplit(x, " ")[[1]] + chars <- as.vector(sapply(x.split, nchar)) + paste(unlist(x.split[cumsum(chars) < maxchar]), collapse = " ") } @@ -645,18 +661,20 @@ randomSentence <- function(n, maxchar=Inf){ #' @param n number of sentences to be generate (integer) #' @param nwords number of words per sentence. If vector each sentence #' lengths is randomly drawn from the vector -#' @param maxchar maximal number of characters per sentence. Note that whole -#' words (not part of words) are excluded if the maximal number +#' @param maxchar maximal number of characters per sentence. Note that whole +#' words (not part of words) are excluded if the maximal number #' is exceeded. #' @return a vector with n random sentences #' @export #' @keywords internal #' @examples -#' randomSentences(5, 10) # five random sentences with ten words each -#' randomSentences(5, 2:10) # five random sentences between two and ten words -randomSentences <- function(n, nwords, maxchar=Inf){ - sapply(sample(nwords, n, replace = TRUE), - randomSentence, maxchar = maxchar) +#' randomSentences(5, 10) # five random sentences with ten words each +#' randomSentences(5, 2:10) # five random sentences between two and ten words +randomSentences <- function(n, nwords, maxchar = Inf) { + sapply(sample(nwords, n, replace = TRUE), + randomSentence, + maxchar = maxchar + ) } @@ -668,17 +686,18 @@ randomSentences <- function(n, nwords, maxchar=Inf){ #' @export #' @keywords internal #' @examples \dontrun{ -#' a <- c("c", "a", "b") -#' b <- c("b", "c", "a") -#' index <- orderByString(a, b) # to order b like a needs what indexes? -#' index -#' b[index] +#' a <- c("c", "a", "b") +#' b <- c("b", "c", "a") +#' index <- orderByString(a, b) # to order b like a needs what indexes? +#' index +#' b[index] #' } #' -orderByString <- function(x, y){ - if (!all(x %in% y)) +orderByString <- function(x, y) { + if (!all(x %in% y)) { stop("vector x and y do not contain the same (differently ordered) elements") - index <- order(order(x)) # reconversion index from sorted to old order + } + index <- order(order(x)) # reconversion index from sorted to old order order(y)[index] } @@ -690,14 +709,12 @@ orderByString <- function(x, y){ # cycle through x[r, c] and multiply by # sum(x elements below and to the right of x[r, c]) # x = table -concordant <- function(x) -{ +concordant <- function(x) { x <- matrix(as.numeric(x), dim(x)) - + # get sum(matrix values > r AND > c) # for each matrix[r, c] - mat.lr <- function(r, c) - { + mat.lr <- function(r, c) { lr <- x[(r.x > r) & (c.x > c)] sum(lr) } @@ -716,14 +733,12 @@ concordant <- function(x) # cycle through x[r, c] and multiply by # sum(x elements below and to the left of x[r, c]) # x = table -discordant <- function(x) -{ +discordant <- function(x) { x <- matrix(as.numeric(x), dim(x)) - + # get sum(matrix values > r AND < c) # for each matrix[r, c] - mat.ll <- function(r, c) - { + mat.ll <- function(r, c) { ll <- x[(r.x > r) & (c.x < c)] sum(ll) } @@ -745,19 +760,18 @@ discordant <- function(x) # 2. Sd R~C # 3. Sd Symmetric (Mean of above) # x = table -calc.Sd <- function(x) -{ +calc.Sd <- function(x) { x <- matrix(as.numeric(x), dim(x)) - + c <- concordant(x) d <- discordant(x) n <- sum(x) SumR <- rowSums(x) SumC <- colSums(x) - Sd.CR <- (2 * (c - d)) / ((n ^ 2) - (sum(SumR ^ 2))) - Sd.RC <- (2 * (c - d)) / ((n ^ 2) - (sum(SumC ^ 2))) - Sd.S <- (2 * (c - d)) / ((n ^ 2) - (((sum(SumR ^ 2)) + (sum(SumC ^ 2))) / 2)) + Sd.CR <- (2 * (c - d)) / ((n^2) - (sum(SumR^2))) + Sd.RC <- (2 * (c - d)) / ((n^2) - (sum(SumC^2))) + Sd.S <- (2 * (c - d)) / ((n^2) - (((sum(SumR^2)) + (sum(SumC^2))) / 2)) Sdlist <- list(Sd.CR, Sd.RC, Sd.S) names(Sdlist) <- c("Sd.CR", "Sd.RC", "Sd.S") @@ -776,10 +790,9 @@ calc.Sd <- function(x) # draw an ellipse # -# -ellipse <- function (hlaxa = 1, hlaxb = 1, theta = 0, xc = 0, yc = 0, - newplot = F, npoints = 100, ...) -{ +# +ellipse <- function(hlaxa = 1, hlaxb = 1, theta = 0, xc = 0, yc = 0, + newplot = F, npoints = 100, ...) { a <- seq(0, 2 * pi, length = npoints + 1) x <- hlaxa * cos(a) y <- hlaxb * sin(a) @@ -787,32 +800,30 @@ ellipse <- function (hlaxa = 1, hlaxb = 1, theta = 0, xc = 0, yc = 0, rad <- sqrt(x^2 + y^2) xp <- rad * cos(alpha + theta) + xc yp <- rad * sin(alpha + theta) + yc - if (newplot) + if (newplot) { plot(xp, yp, type = "l", ...) - else lines(xp, yp, ...) + } else { + lines(xp, yp, ...) + } invisible() } -angle <- function (x, y) -{ +angle <- function(x, y) { angle2 <- function(xy) { x <- xy[1] y <- xy[2] if (x > 0) { - atan(y/x) + atan(y / x) } else { if (x < 0 & y != 0) { - atan(y/x) + sign(y) * pi - } - else { + atan(y / x) + sign(y) * pi + } else { if (x < 0 & y == 0) { pi - } - else { + } else { if (y != 0) { - (sign(y) * pi)/2 - } - else { + (sign(y) * pi) / 2 + } else { NA } } @@ -823,9 +834,9 @@ angle <- function (x, y) } -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// ### FORMATTING #### -#////////////////////////////////////////////////////////////////////////////// +# ////////////////////////////////////////////////////////////////////////////// #' Format a matrix and add index column. #' @@ -835,31 +846,34 @@ angle <- function (x, y) #' @param pre.index Whether to make index prefix for rows and column names. #' @param indexcol Whether to make an index column. #' @param diag Whether to show diagonal. -#' @param mode Whether to show upper (mode=1), lower (mode=2) +#' @param mode Whether to show upper (mode=1), lower (mode=2) #' or both triangles (mode=0) of the matrix. #' @keywords internal #' @export #' -formatMatrix <- function(x, rnames=rownames(x), pre.index=c(T,F), - cnames=seq_len(ncol(x)), indexcol=F, digits=2, - diag=F, mode=1) -{ - blanks <- paste(rep(" ", digits + 2), collapse="") - if (mode == 1) - x[lower.tri(x, diag=!diag)] <- blanks - if (mode == 2) - x[upper.tri(x, diag=!diag)] <- blanks - - if (pre.index[1]) - rnames <- paste(seq_len(nrow(x)), rnames) - if (pre.index[2]) +formatMatrix <- function(x, rnames = rownames(x), pre.index = c(T, F), + cnames = seq_len(ncol(x)), indexcol = F, digits = 2, + diag = F, mode = 1) { + blanks <- paste(rep(" ", digits + 2), collapse = "") + if (mode == 1) { + x[lower.tri(x, diag = !diag)] <- blanks + } + if (mode == 2) { + x[upper.tri(x, diag = !diag)] <- blanks + } + + if (pre.index[1]) { + rnames <- paste(seq_len(nrow(x)), rnames) + } + if (pre.index[2]) { cnames <- paste(seq_len(ncol(x)), cnames) + } if (indexcol) { rownames(x) <- rnames - x <- addIndexColumnToMatrix(x) + x <- addIndexColumnToMatrix(x) } else { rownames(x) <- rnames - colnames(x) <- cnames + colnames(x) <- cnames } x } @@ -868,19 +882,21 @@ formatMatrix <- function(x, rnames=rownames(x), pre.index=c(T,F), # add names to columns and rows and do trimming # along 1=constructs, 2=elements # -addNamesToMatrix <- function(x, m, trim=7, along=1){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - if (along == 1){ +addNamesToMatrix <- function(x, m, trim = 7, along = 1) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + if (along == 1) { cnamesl <- constructs(x)$leftpole cnamesr <- constructs(x)$rightpole new.names <- paste(cnamesl, cnamesr, sep = " - ") } else { new.names <- elements(x) } - if (!is.na(trim)) # trim constructs if prompted + if (!is.na(trim)) { # trim constructs if prompted new.names <- substr(new.names, 1, trim) - rownames(m) <- colnames(m) <- new.names # assign new names to row and column names + } + rownames(m) <- colnames(m) <- new.names # assign new names to row and column names m } @@ -888,34 +904,36 @@ addNamesToMatrix <- function(x, m, trim=7, along=1){ # add names to columns and rows and do trimming # along 1=constructs, 2=elements # -addNamesToMatrix2 <- function(x, m, index=F, trim=7, along=1){ - if (!inherits(x, "repgrid")) # check if x is repgrid object - stop("Object x must be of class 'repgrid'") - if (along == 1){ - new.names <- getConstructNames2(x, index=index, trim=trim) +addNamesToMatrix2 <- function(x, m, index = F, trim = 7, along = 1) { + if (!inherits(x, "repgrid")) { # check if x is repgrid object + stop("Object x must be of class 'repgrid'") + } + if (along == 1) { + new.names <- getConstructNames2(x, index = index, trim = trim) } else { - new.names <- getElementNames2(x, index=index, trim=trim) + new.names <- getElementNames2(x, index = index, trim = trim) } - rownames(m) <- colnames(m) <- new.names # assign new names to row and column names + rownames(m) <- colnames(m) <- new.names # assign new names to row and column names m } #' add index column for neater colnames #' #' -#' @param x `matrix` object +#' @param x `matrix` object #' @export #' @keywords internal #' @examples \dontrun{ -#' x <- matrix(1:9, 3) -#' colnames(x) <- rep("Long names that occupiy too much space", 3) -#' rownames(x) <- rep("Some text", 3) -#' addIndexColumnToMatrix(x) +#' x <- matrix(1:9, 3) +#' colnames(x) <- rep("Long names that occupiy too much space", 3) +#' rownames(x) <- rep("Some text", 3) +#' addIndexColumnToMatrix(x) #' } #' -addIndexColumnToMatrix <- function(x){ - if (dim(x)[1] != dim(x)[2]) +addIndexColumnToMatrix <- function(x) { + if (dim(x)[1] != dim(x)[2]) { stop("works for square matrices only") + } indexes <- 1L:dim(x)[1] res <- cbind(indexes, x) colnames(res) <- c(" ", indexes) @@ -929,33 +947,35 @@ addIndexColumnToMatrix <- function(x){ #' @title Density histogram with steps instead of bars #' #' @param vals Numeric values to display. -#' @param breaks Passed on to `hist`. +#' @param breaks Passed on to `hist`. #' See ?hist parameter `breaks` for more information. #' @param add Whether to add the steps to an existing plot (`FALSE`) -#' or to create a new plot (default `add=TRUE`). +#' or to create a new plot (default `add=TRUE`). #' @export -#' @keywords internal +#' @keywords internal #' @examples \dontrun{ #' -#' x <- rnorm(1000) -#' y <- rnorm(1000, sd=.6) -#' stepChart(y, breaks=50) -#' stepChart(x, add=T, breaks=50, col="red") +#' x <- rnorm(1000) +#' y <- rnorm(1000, sd = .6) +#' stepChart(y, breaks = 50) +#' stepChart(x, add = T, breaks = 50, col = "red") #' } #' -stepChart <- function(vals, breaks="Sturges", add=FALSE, ...){ - h <- hist(vals, breaks=breaks, plot=F) +stepChart <- function(vals, breaks = "Sturges", add = FALSE, ...) { + h <- hist(vals, breaks = breaks, plot = F) x <- h$breaks y <- h$density x <- c(x, x[length(x)]) y <- c(0, y, 0) - if (add) - points(x, y, type="s", ...) else - plot(x, y, type="s", ...) + if (add) { + points(x, y, type = "s", ...) + } else { + plot(x, y, type = "s", ...) + } } -list_to_dataframe <- function(l){ - #plyr:::list_to_dataframe(l) +list_to_dataframe <- function(l) { + # plyr:::list_to_dataframe(l) do.call(rbind.data.frame, l) } diff --git a/R/zzz.r b/R/zzz.r index d1ee6c22..c23f7f6b 100644 --- a/R/zzz.r +++ b/R/zzz.r @@ -21,17 +21,18 @@ assign("settings", list(), envir = .OpenRepGridEnv) -.onAttach <- function(lib, pkg){ +.onAttach <- function(lib, pkg) { packageStartupMessage( - "------------------------------------------------", - "\n OpenRepGrid Version ", utils::packageDescription("OpenRepGrid", fields = "Version"), - "\n Tools for the analysis of repertory grid data", - "\n For an introduction visit: www.openrepgrid.org", - "\n CAUTION: The package is in alpha phase.", - "\n Design changes may still occur.", - "\n------------------------------------------------", - appendLF = TRUE) - + "------------------------------------------------", + "\n OpenRepGrid Version ", utils::packageDescription("OpenRepGrid", fields = "Version"), + "\n Tools for the analysis of repertory grid data", + "\n For an introduction visit: www.openrepgrid.org", + "\n CAUTION: The package is in alpha phase.", + "\n Design changes may still occur.", + "\n------------------------------------------------", + appendLF = TRUE + ) + # invisible object saved in environment in namespace setDefaultSettings() } @@ -40,4 +41,4 @@ assign("settings", list(), envir = .OpenRepGridEnv) # clean up workspace # .onUnload <- function(lib){ # -# } +# } diff --git a/demo/OpenRepGrid.r b/demo/OpenRepGrid.r index 9035edec..2a92d704 100644 --- a/demo/OpenRepGrid.r +++ b/demo/OpenRepGrid.r @@ -1,52 +1,53 @@ -if (interactive()) - old.prompt <- devAskNewPage(TRUE) - -################################################## -# Some examples from the OpenRepGrid package # -################################################## - -#### Biplots #### -plot(0, type="n", xaxt="n", yaxt="n", xlab="", ylab="") -text(1, 0, "Biplots", cex=5) - -#### Standard biplot #### -biplot2d(feixas2004) - -#### Slater's INGRID biplot #### -biplotSlater2d(feixas2004) - -#### Creating an ESA biplot #### -biplotEsa2d(feixas2004) - -#### Pseudo 3D biplot ##### -biplotPseudo3d(feixas2004) - -#### 3D biplot ##### -x <- scan(n=1) -biplot3d(boeker) - -#### Bertin displays #### -plot(0, type="n", xaxt="n", yaxt="n", xlab="", ylab="") -text(1, 0, "Bertin \ndisplay", cex=5) - -#### Bertin display #### -bertin(feixas2004) - -#### Colored display #### -bertin(feixas2004, colors=c("white", "darkred")) - -#### Clustered Bertin display #### -x <- scan(n=1) -dev.off() -dev.new() - -plot(0, type="n", xaxt="n", yaxt="n", xlab="", ylab="") -text(1, 0, "Clustered \nBertin display", cex=5) - -#### Clustered Bertin display #### -bertinCluster(feixas2004) - -############################################### -if (interactive()) - devAskNewPage(old.prompt) - \ No newline at end of file +if (interactive()) { + old.prompt <- devAskNewPage(TRUE) +} + +################################################## +# Some examples from the OpenRepGrid package # +################################################## + +#### Biplots #### +plot(0, type = "n", xaxt = "n", yaxt = "n", xlab = "", ylab = "") +text(1, 0, "Biplots", cex = 5) + +#### Standard biplot #### +biplot2d(feixas2004) + +#### Slater's INGRID biplot #### +biplotSlater2d(feixas2004) + +#### Creating an ESA biplot #### +biplotEsa2d(feixas2004) + +#### Pseudo 3D biplot ##### +biplotPseudo3d(feixas2004) + +#### 3D biplot ##### +x <- scan(n = 1) +biplot3d(boeker) + +#### Bertin displays #### +plot(0, type = "n", xaxt = "n", yaxt = "n", xlab = "", ylab = "") +text(1, 0, "Bertin \ndisplay", cex = 5) + +#### Bertin display #### +bertin(feixas2004) + +#### Colored display #### +bertin(feixas2004, colors = c("white", "darkred")) + +#### Clustered Bertin display #### +x <- scan(n = 1) +dev.off() +dev.new() + +plot(0, type = "n", xaxt = "n", yaxt = "n", xlab = "", ylab = "") +text(1, 0, "Clustered \nBertin display", cex = 5) + +#### Clustered Bertin display #### +bertinCluster(feixas2004) + +############################################### +if (interactive()) { + devAskNewPage(old.prompt) +} diff --git a/man/OpenRepGrid-overview.Rd b/man/OpenRepGrid-overview.Rd index 7163f97b..af368d1e 100644 --- a/man/OpenRepGrid-overview.Rd +++ b/man/OpenRepGrid-overview.Rd @@ -226,7 +226,7 @@ Everyone who is interested in developing the package is invited to join. \if{html}{\out{
}}\preformatted{ The \pkg{OpenRepGrid} package development is hosted on github (). The github site provides information and allows to file bug reports or feature requests. - Bug reports can also be emailed to the package maintainer or issued on + Bug reports can also be emailed to the package maintainer or issued on under section *Suggestions/Issues*. The package maintainer is Mark Heckmann . }\if{html}{\out{
}} diff --git a/man/addAvgElement.Rd b/man/addAvgElement.Rd index 5584fd2d..ac42838d 100644 --- a/man/addAvgElement.Rd +++ b/man/addAvgElement.Rd @@ -31,7 +31,6 @@ addAvgElement(feixas2004, "others", i = 2:12) addAvgElement(feixas2004, "others", i = 2:12, digits = 0) # integers # exluding elements via negative indexes -addAvgElement(feixas2004, "others", i = c(-1,-13)) - +addAvgElement(feixas2004, "others", i = c(-1, -13)) } diff --git a/man/addConstruct.Rd b/man/addConstruct.Rd index fd9a24bf..383384e1 100644 --- a/man/addConstruct.Rd +++ b/man/addConstruct.Rd @@ -49,10 +49,9 @@ Add a new construct to an existing grid object. \examples{ \dontrun{ - # show grid - bell2010 - addConstruct(bell2010, "left pole", "pole right", c(3,1,3,2,5,4,6,3,7,1)) - +# show grid +bell2010 +addConstruct(bell2010, "left pole", "pole right", c(3, 1, 3, 2, 5, 4, 6, 3, 7, 1)) } } diff --git a/man/addElement.Rd b/man/addElement.Rd index f389e039..f03cca37 100644 --- a/man/addElement.Rd +++ b/man/addElement.Rd @@ -40,9 +40,8 @@ Add an element to an existing grid. \examples{ \dontrun{ - bell2010 - addElement(bell2010, "new element", c(1,2,5,4,3,6,5,2,7)) - +bell2010 +addElement(bell2010, "new element", c(1, 2, 5, 4, 3, 6, 5, 2, 7)) } } diff --git a/man/addIndexColumnToMatrix.Rd b/man/addIndexColumnToMatrix.Rd index 6c9e49b8..8121a277 100644 --- a/man/addIndexColumnToMatrix.Rd +++ b/man/addIndexColumnToMatrix.Rd @@ -14,10 +14,10 @@ add index column for neater colnames } \examples{ \dontrun{ - x <- matrix(1:9, 3) - colnames(x) <- rep("Long names that occupiy too much space", 3) - rownames(x) <- rep("Some text", 3) - addIndexColumnToMatrix(x) +x <- matrix(1:9, 3) +colnames(x) <- rep("Long names that occupiy too much space", 3) +rownames(x) <- rep("Some text", 3) +addIndexColumnToMatrix(x) } } diff --git a/man/alignByIdeal.Rd b/man/alignByIdeal.Rd index 1647fdd5..dd4b5054 100644 --- a/man/alignByIdeal.Rd +++ b/man/alignByIdeal.Rd @@ -31,11 +31,11 @@ cannot be determined definitely, the construct direction remains unchanged (a wa } \examples{ - feixas2004 # original grid - alignByIdeal(feixas2004, 13) # aligned with preference pole on the right +feixas2004 # original grid +alignByIdeal(feixas2004, 13) # aligned with preference pole on the right - raeithel # original grid - alignByIdeal(raeithel, 3, high=FALSE) # aligned with preference pole on the left +raeithel # original grid +alignByIdeal(raeithel, 3, high = FALSE) # aligned with preference pole on the left } \references{ diff --git a/man/alignByLoadings.Rd b/man/alignByLoadings.Rd index d403b08b..6312c0b9 100644 --- a/man/alignByLoadings.Rd +++ b/man/alignByLoadings.Rd @@ -45,24 +45,24 @@ proposes to align constructs in a way so they all have positive loadings on the } \examples{ - # reproduction of the example in the Bell (2010) - # constructs aligned by loadings on PC 1 - bell2010 - alignByLoadings(bell2010) +# reproduction of the example in the Bell (2010) +# constructs aligned by loadings on PC 1 +bell2010 +alignByLoadings(bell2010) - # save results - a <- alignByLoadings(bell2010) +# save results +a <- alignByLoadings(bell2010) - # modify printing of resukts - print(a, digits=5) +# modify printing of resukts +print(a, digits = 5) - # access results for further processing - names(a) - a$cor.before - a$loadings.before - a$reversed - a$cor.after - a$loadings.after +# access results for further processing +names(a) +a$cor.before +a$loadings.before +a$reversed +a$cor.after +a$loadings.after } \references{ diff --git a/man/angleOrderIndexes2d.Rd b/man/angleOrderIndexes2d.Rd index bf56edb4..e353473f 100644 --- a/man/angleOrderIndexes2d.Rd +++ b/man/angleOrderIndexes2d.Rd @@ -23,11 +23,11 @@ Reorder indexes for constructs and elements are calculated using the coordinates \examples{ \dontrun{ - x <- randomGrid(15,30) # make random grid - i <- angleOrderIndexes2d(x) # make indexes for ordering - x <- x[i[[1]], i[[2]]] # reorder constructs and elements - x # print grid +x <- randomGrid(15, 30) # make random grid +i <- angleOrderIndexes2d(x) # make indexes for ordering +x <- x[i[[1]], i[[2]]] # reorder constructs and elements +x # print grid } - + } \keyword{internal} diff --git a/man/apply_pb.Rd b/man/apply_pb.Rd index 82995adc..159d3a49 100644 --- a/man/apply_pb.Rd +++ b/man/apply_pb.Rd @@ -25,17 +25,16 @@ it does is create an additional progress bar. \examples{ \dontrun{ - apply_pb(anscombe, 2, sd, na.rm=TRUE) +apply_pb(anscombe, 2, sd, na.rm = TRUE) - # larger dataset - df <- data.frame(rnorm(30000), rnorm(30000)) - head(apply_pb(df, 1, sd)) - - # performance comparison - df <- data.frame(rnorm(90000), rnorm(90000)) - system.time(apply(df, 1, sd)) - system.time(apply_pb(df, 1, sd)) +# larger dataset +df <- data.frame(rnorm(30000), rnorm(30000)) +head(apply_pb(df, 1, sd)) +# performance comparison +df <- data.frame(rnorm(90000), rnorm(90000)) +system.time(apply(df, 1, sd)) +system.time(apply_pb(df, 1, sd)) } } diff --git a/man/bertin.Rd b/man/bertin.Rd index 0472f54d..6763980d 100644 --- a/man/bertin.Rd +++ b/man/bertin.Rd @@ -93,16 +93,16 @@ values correspond to low, dark to high scores. For an example of how to analyze } \examples{ - bertin(feixas2004) - bertin(feixas2004, c("white", "darkblue")) - bertin(feixas2004, showvalues=FALSE) - bertin(feixas2004, border="grey") - bertin(feixas2004, cex.text=.9) - bertin(feixas2004, id=c(FALSE, FALSE)) - - bertin(feixas2004, cc=3, cr=4) - bertin(feixas2004, cc=3, cr=4, col.mark.fill="#e6e6e6") - +bertin(feixas2004) +bertin(feixas2004, c("white", "darkblue")) +bertin(feixas2004, showvalues = FALSE) +bertin(feixas2004, border = "grey") +bertin(feixas2004, cex.text = .9) +bertin(feixas2004, id = c(FALSE, FALSE)) + +bertin(feixas2004, cc = 3, cr = 4) +bertin(feixas2004, cc = 3, cr = 4, col.mark.fill = "#e6e6e6") + } \references{ Bertin, J. (1974). \emph{Graphische Semiologie: Diagramme, Netze, Karten}. Berlin, New York: de Gruyter. diff --git a/man/bertinCluster.Rd b/man/bertinCluster.Rd index 9381c60f..88c84c5d 100644 --- a/man/bertinCluster.Rd +++ b/man/bertinCluster.Rd @@ -100,53 +100,53 @@ cluster methods are supported. } \examples{ - # default is euclidean distance and ward clustering - bertinCluster(bell2010) - - ### applying different distance measures and cluster methods - - # euclidean distance and single linkage clustering - bertinCluster(bell2010, cmethod="single") - # manhattan distance and single linkage clustering - bertinCluster(bell2010, dmethod="manhattan", cm="single") - # minkowksi distance with power of 2 = euclidean distance - bertinCluster(bell2010, dm="mink", p=2) - - ### using different methods for constructs and elements - - # ward clustering for constructs, single linkage for elements - bertinCluster(bell2010, cmethod=c("ward.D", "single")) - # euclidean distance measure for constructs, manhatten - # distance for elements - bertinCluster(bell2010, dmethod=c("euclidean", "man")) - # minkowski metric with different powers for constructs and elements - bertinCluster(bell2010, dmethod="mink", p=c(2,1)) - - ### clustering either constructs or elements only - # euclidean distance and ward clustering for constructs no - # clustering for elements - bertinCluster(bell2010, cmethod=c("ward.D", NA)) - # euclidean distance and single linkage clustering for elements - # no clustering for constructs - bertinCluster(bell2010, cm=c(NA, "single"), align=FALSE) - - ### changing the appearance - # different dendrogram type - bertinCluster(bell2010, type="rectangle") - # no axis drawn for dendrogram - bertinCluster(bell2010, draw.axis=FALSE) - - ### passing on arguments to bertin function via ... - # grey cell borders in bertin display - bertinCluster(bell2010, border="grey") - # omit printing of grid scores, i.e. colors only - bertinCluster(bell2010, showvalues=FALSE) - - ### changing the layout - # making the vertical dendrogram bigger - bertinCluster(bell2010, xsegs=c(0, .2, .5, .7, 1)) - # making the horizontal dendrogram bigger - bertinCluster(bell2010, ysegs=c(0, .3, .8, 1)) +# default is euclidean distance and ward clustering +bertinCluster(bell2010) + +### applying different distance measures and cluster methods + +# euclidean distance and single linkage clustering +bertinCluster(bell2010, cmethod = "single") +# manhattan distance and single linkage clustering +bertinCluster(bell2010, dmethod = "manhattan", cm = "single") +# minkowksi distance with power of 2 = euclidean distance +bertinCluster(bell2010, dm = "mink", p = 2) + +### using different methods for constructs and elements + +# ward clustering for constructs, single linkage for elements +bertinCluster(bell2010, cmethod = c("ward.D", "single")) +# euclidean distance measure for constructs, manhatten +# distance for elements +bertinCluster(bell2010, dmethod = c("euclidean", "man")) +# minkowski metric with different powers for constructs and elements +bertinCluster(bell2010, dmethod = "mink", p = c(2, 1)) + +### clustering either constructs or elements only +# euclidean distance and ward clustering for constructs no +# clustering for elements +bertinCluster(bell2010, cmethod = c("ward.D", NA)) +# euclidean distance and single linkage clustering for elements +# no clustering for constructs +bertinCluster(bell2010, cm = c(NA, "single"), align = FALSE) + +### changing the appearance +# different dendrogram type +bertinCluster(bell2010, type = "rectangle") +# no axis drawn for dendrogram +bertinCluster(bell2010, draw.axis = FALSE) + +### passing on arguments to bertin function via ... +# grey cell borders in bertin display +bertinCluster(bell2010, border = "grey") +# omit printing of grid scores, i.e. colors only +bertinCluster(bell2010, showvalues = FALSE) + +### changing the layout +# making the vertical dendrogram bigger +bertinCluster(bell2010, xsegs = c(0, .2, .5, .7, 1)) +# making the horizontal dendrogram bigger +bertinCluster(bell2010, ysegs = c(0, .3, .8, 1)) } \seealso{ diff --git a/man/bind.Rd b/man/bind.Rd index 0465cbdb..557ba76d 100644 --- a/man/bind.Rd +++ b/man/bind.Rd @@ -31,12 +31,12 @@ as one 'big grid' (eg. Slater, 1977, chap. 11). \examples{ \dontrun{ - a <- randomGrid() - b <- randomGrid() - b@elements <- rev(a@elements) # reverse elements - bindConstructs(a, b) - - bindConstructs(a, b, m=F) # no binding +a <- randomGrid() +b <- randomGrid() +elements(b) <- rev(elements(a)) # reverse elements +bindConstructs(a, b) + +bindConstructs(a, b, m = F) # no binding } } diff --git a/man/bindConstructs.Rd b/man/bindConstructs.Rd index 8a45961e..2dda178c 100644 --- a/man/bindConstructs.Rd +++ b/man/bindConstructs.Rd @@ -28,14 +28,14 @@ as one 'big grid' (eg. Slater, 1977, chap. 11). } \examples{ - a <- randomGrid() - b <- randomGrid() - b@elements <- rev(a@elements) # reverse elements - bindConstructs(a, b) - bindConstructs(a, b, a) - - # using lists of repgrid objects - bindConstructs(a, list(a, b)) +a <- randomGrid() +b <- randomGrid() +elements(b) <- rev(elements(a)) # reverse elements +bindConstructs(a, b) +bindConstructs(a, b, a) + +# using lists of repgrid objects +bindConstructs(a, list(a, b)) } \references{ diff --git a/man/biplot2d.Rd b/man/biplot2d.Rd index 3e23bfbe..0173f736 100644 --- a/man/biplot2d.Rd +++ b/man/biplot2d.Rd @@ -279,46 +279,48 @@ the projection property is only given if \eqn{g + h = 1}{g + h = 1} \examples{ \dontrun{ - biplot2d(boeker) # biplot of boeker data - biplot2d(boeker, c.lines=T) # add construct lines - biplot2d(boeker, center=2) # with column centering - biplot2d(boeker, center=4) # midpoint centering - biplot2d(boeker, normalize=1) # normalization of constructs - - biplot2d(boeker, dim=2:3) # plot 2nd and 3rd dimension - biplot2d(boeker, dim=c(1,4)) # plot 1st and 4th dimension - - biplot2d(boeker, g=1, h=1) # assign singular values to con. & elem. - biplot2d(boeker, g=1, h=1, center=1) # row centering (Slater) - biplot2d(boeker, g=1, h=1, center=4) # midpoint centering (ESA) - - biplot2d(boeker, e.color="red", c.color="blue") # change colors - biplot2d(boeker, c.color=c("white", "darkred")) # mapped onto color range - - biplot2d(boeker, unity=T) # scale con. & elem. to equal length - biplot2d(boeker, unity=T, scale.e=.5) # scaling factor for element vectors - - biplot2d(boeker, e.labels.show=F) # do not show element labels - biplot2d(boeker, e.labels.show=c(1,2,4)) # show labels for elements 1, 2 and 4 - biplot2d(boeker, e.points.show=c(1,2,4)) # only show elements 1, 2 and 4 - biplot2d(boeker, c.labels.show=c(1:4)) # show constructs labels 1 to 4 - biplot2d(boeker, c.labels.show=c(1:4)) # show constructs labels except 1 to 4 - - biplot2d(boeker, e.cex.map=1) # change size of texts for elements - biplot2d(boeker, c.cex.map=1) # change size of texts for constructs - - biplot2d(boeker, g=1, h=1, c.labels.inside=T) # constructs inside the plot - biplot2d(boeker, g=1, h=1, c.labels.inside=T, # different margins and elem. color - mai=c(0,0,0,0), e.color="red") - - biplot2d(boeker, strokes.x=.3, strokes.y=.05) # change length of strokes - - biplot2d(boeker, flipaxes=c(T, F)) # flip x axis - biplot2d(boeker, flipaxes=c(T, T)) # flip x and y axis - - biplot2d(boeker, outer.positioning=F) # no positioning of con.-labels - - biplot2d(boeker, c.labels.devangle=20) # only con. within 20 degree angle +biplot2d(boeker) # biplot of boeker data +biplot2d(boeker, c.lines = T) # add construct lines +biplot2d(boeker, center = 2) # with column centering +biplot2d(boeker, center = 4) # midpoint centering +biplot2d(boeker, normalize = 1) # normalization of constructs + +biplot2d(boeker, dim = 2:3) # plot 2nd and 3rd dimension +biplot2d(boeker, dim = c(1, 4)) # plot 1st and 4th dimension + +biplot2d(boeker, g = 1, h = 1) # assign singular values to con. & elem. +biplot2d(boeker, g = 1, h = 1, center = 1) # row centering (Slater) +biplot2d(boeker, g = 1, h = 1, center = 4) # midpoint centering (ESA) + +biplot2d(boeker, e.color = "red", c.color = "blue") # change colors +biplot2d(boeker, c.color = c("white", "darkred")) # mapped onto color range + +biplot2d(boeker, unity = T) # scale con. & elem. to equal length +biplot2d(boeker, unity = T, scale.e = .5) # scaling factor for element vectors + +biplot2d(boeker, e.labels.show = F) # do not show element labels +biplot2d(boeker, e.labels.show = c(1, 2, 4)) # show labels for elements 1, 2 and 4 +biplot2d(boeker, e.points.show = c(1, 2, 4)) # only show elements 1, 2 and 4 +biplot2d(boeker, c.labels.show = c(1:4)) # show constructs labels 1 to 4 +biplot2d(boeker, c.labels.show = c(1:4)) # show constructs labels except 1 to 4 + +biplot2d(boeker, e.cex.map = 1) # change size of texts for elements +biplot2d(boeker, c.cex.map = 1) # change size of texts for constructs + +biplot2d(boeker, g = 1, h = 1, c.labels.inside = T) # constructs inside the plot +biplot2d(boeker, + g = 1, h = 1, c.labels.inside = T, # different margins and elem. color + mai = c(0, 0, 0, 0), e.color = "red" +) + +biplot2d(boeker, strokes.x = .3, strokes.y = .05) # change length of strokes + +biplot2d(boeker, flipaxes = c(T, F)) # flip x axis +biplot2d(boeker, flipaxes = c(T, T)) # flip x and y axis + +biplot2d(boeker, outer.positioning = F) # no positioning of con.-labels + +biplot2d(boeker, c.labels.devangle = 20) # only con. within 20 degree angle } } diff --git a/man/biplot3d.Rd b/man/biplot3d.Rd index c18849a3..aa927c32 100644 --- a/man/biplot3d.Rd +++ b/man/biplot3d.Rd @@ -114,17 +114,21 @@ of elements under investigation (e.g. Raeithel, 1998). \examples{ \dontrun{ - biplot3d(boeker) - biplot3d(boeker, unity3d=T) +biplot3d(boeker) +biplot3d(boeker, unity3d = T) - biplot3d(boeker, e.sphere.col="red", - c.text.col="blue") - biplot3d(boeker, e.cex=1) - biplot3d(boeker, col.sphere="red") +biplot3d(boeker, + e.sphere.col = "red", + c.text.col = "blue" +) +biplot3d(boeker, e.cex = 1) +biplot3d(boeker, col.sphere = "red") - biplot3d(boeker, g=1, h=1) # INGRID biplot - biplot3d(boeker, g=1, h=1, # ESA biplot - center=4) +biplot3d(boeker, g = 1, h = 1) # INGRID biplot +biplot3d(boeker, + g = 1, h = 1, # ESA biplot + center = 4 +) } } diff --git a/man/biplotEsa2d.Rd b/man/biplotEsa2d.Rd index 2cbf830a..9f5f3b35 100644 --- a/man/biplotEsa2d.Rd +++ b/man/biplotEsa2d.Rd @@ -36,8 +36,8 @@ To see all the parameters that can be changed see \code{\link[=biplot2d]{biplot2 } \examples{ \dontrun{ - # See examples in [biplot2d()] as the same arguments - # can used for this function. +# See examples in [biplot2d()] as the same arguments +# can used for this function. } } diff --git a/man/biplotEsa3d.Rd b/man/biplotEsa3d.Rd index 042258d6..7aee01e1 100644 --- a/man/biplotEsa3d.Rd +++ b/man/biplotEsa3d.Rd @@ -40,14 +40,15 @@ of a biplot that can also be produced using the \examples{ \dontrun{ - biplotEsa3d(boeker) - biplotEsa3d(boeker, unity3d=T) - - biplotEsa3d(boeker, e.sphere.col="red", - c.text.col="blue") - biplotEsa3d(boeker, e.cex=1) - biplotEsa3d(boeker, col.sphere="red") +biplotEsa3d(boeker) +biplotEsa3d(boeker, unity3d = T) +biplotEsa3d(boeker, + e.sphere.col = "red", + c.text.col = "blue" +) +biplotEsa3d(boeker, e.cex = 1) +biplotEsa3d(boeker, col.sphere = "red") } } diff --git a/man/biplotEsaPseudo3d.Rd b/man/biplotEsaPseudo3d.Rd index 6d941e8f..dff2f5c0 100644 --- a/man/biplotEsaPseudo3d.Rd +++ b/man/biplotEsaPseudo3d.Rd @@ -40,8 +40,8 @@ and \code{\link[=biplotPseudo3d]{biplotPseudo3d()}}. } \examples{ \dontrun{ - # See examples in [biplotPseudo3d()] as the same arguments - # can used for this function. +# See examples in [biplotPseudo3d()] as the same arguments +# can used for this function. } } diff --git a/man/biplotPseudo3d.Rd b/man/biplotPseudo3d.Rd index 9e4101a5..4d3205a0 100644 --- a/man/biplotPseudo3d.Rd +++ b/man/biplotPseudo3d.Rd @@ -107,25 +107,25 @@ see \code{\link[=biplot2d]{biplot2d()}}. Here only the arguments special to } \examples{ \dontrun{ - # biplot with 3D impression - biplotPseudo3d(boeker) - # Slater's biplot with 3D impression - biplotPseudo3d(boeker, g=1, h=1, center=1) - - # show 2nd and 3rd dim. and map 4th - biplotPseudo3d(boeker, dim=2:3, map.dim=4) - - # change elem. colors - biplotPseudo3d(boeker, e.color=c("white", "darkgreen")) - # change con. colors - biplotPseudo3d(boeker, c.color=c("white", "darkgreen")) - # change color mapping range - biplotPseudo3d(boeker, c.colors.map=c(0, 1)) - - # set uniform con. text size - biplotPseudo3d(boeker, c.cex=1) - # change text size mapping range - biplotPseudo3d(boeker, c.cex=c(.4, 1.2)) +# biplot with 3D impression +biplotPseudo3d(boeker) +# Slater's biplot with 3D impression +biplotPseudo3d(boeker, g = 1, h = 1, center = 1) + +# show 2nd and 3rd dim. and map 4th +biplotPseudo3d(boeker, dim = 2:3, map.dim = 4) + +# change elem. colors +biplotPseudo3d(boeker, e.color = c("white", "darkgreen")) +# change con. colors +biplotPseudo3d(boeker, c.color = c("white", "darkgreen")) +# change color mapping range +biplotPseudo3d(boeker, c.colors.map = c(0, 1)) + +# set uniform con. text size +biplotPseudo3d(boeker, c.cex = 1) +# change text size mapping range +biplotPseudo3d(boeker, c.cex = c(.4, 1.2)) } } diff --git a/man/biplotSimple.Rd b/man/biplotSimple.Rd index ac08325f..26c48aa7 100644 --- a/man/biplotSimple.Rd +++ b/man/biplotSimple.Rd @@ -91,19 +91,21 @@ exploration used during development. } \examples{ \dontrun{ - - biplotSimple(boeker) - biplotSimple(boeker, unity=F) - biplotSimple(boeker, g=1, h=1) # INGRID biplot - biplotSimple(boeker, g=1, h=1, center=4) # ESA biplot +biplotSimple(boeker) +biplotSimple(boeker, unity = F) - biplotSimple(boeker, zoom=.9) # zooming out - biplotSimple(boeker, scale.e=.6) # scale element vectors +biplotSimple(boeker, g = 1, h = 1) # INGRID biplot +biplotSimple(boeker, g = 1, h = 1, center = 4) # ESA biplot - biplotSimple(boeker, e.point.col="brown") # change colors - biplotSimple(boeker, e.point.col="brown", - c.label.col="darkblue") +biplotSimple(boeker, zoom = .9) # zooming out +biplotSimple(boeker, scale.e = .6) # scale element vectors + +biplotSimple(boeker, e.point.col = "brown") # change colors +biplotSimple(boeker, + e.point.col = "brown", + c.label.col = "darkblue" +) } } diff --git a/man/biplotSlater2d.Rd b/man/biplotSlater2d.Rd index 5a5e069a..b435cedc 100644 --- a/man/biplotSlater2d.Rd +++ b/man/biplotSlater2d.Rd @@ -35,8 +35,8 @@ To see all the parameters that can be changed see \code{\link[=biplot2d]{biplot2 } \examples{ \dontrun{ - # See examples in [biplot2d()] as the same arguments - # can used for this function. +# See examples in [biplot2d()] as the same arguments +# can used for this function. } } diff --git a/man/biplotSlater3d.Rd b/man/biplotSlater3d.Rd index 5fba9900..e0da47fd 100644 --- a/man/biplotSlater3d.Rd +++ b/man/biplotSlater3d.Rd @@ -39,14 +39,15 @@ function with the arguments \verb{center=1, g=1, h=1}. \examples{ \dontrun{ - biplotSlater3d(boeker) - biplotSlater3d(boeker, unity3d=T) - - biplotSlater3d(boeker, e.sphere.col="red", - c.text.col="blue") - biplotSlater3d(boeker, e.cex=1) - biplotSlater3d(boeker, col.sphere="red") +biplotSlater3d(boeker) +biplotSlater3d(boeker, unity3d = T) +biplotSlater3d(boeker, + e.sphere.col = "red", + c.text.col = "blue" +) +biplotSlater3d(boeker, e.cex = 1) +biplotSlater3d(boeker, col.sphere = "red") } } diff --git a/man/biplotSlaterPseudo3d.Rd b/man/biplotSlaterPseudo3d.Rd index 26903379..672caafc 100644 --- a/man/biplotSlaterPseudo3d.Rd +++ b/man/biplotSlaterPseudo3d.Rd @@ -34,8 +34,8 @@ and \code{\link[=biplotPseudo3d]{biplotPseudo3d()}}. } \examples{ \dontrun{ - # See examples in [biplotPseudo3d()] as the same arguments - # can used for this function. +# See examples in [biplotPseudo3d()] as the same arguments +# can used for this function. } } diff --git a/man/calcCoordsBorders.Rd b/man/calcCoordsBorders.Rd index 50496c56..a054d4be 100644 --- a/man/calcCoordsBorders.Rd +++ b/man/calcCoordsBorders.Rd @@ -30,14 +30,14 @@ Currently the vector is supposed to start in the origin \code{c(0,0)}. } \examples{ \dontrun{ - calcCoordsBorders(1:10, 10:1) +calcCoordsBorders(1:10, 10:1) - x <- c(-100:0, 0:100, 100:0, 0:-100)/10 - y <- c(0:100, 100:0, -(0:100), -(100:0))/10 - xy1 <- calcCoordsBorders(x, y) - xy2 <- calcCoordsBorders(x, y, xm=1.2, ym=1.2) - plot(xy2[,1], xy2[,2], type="n") - segments(xy1[,1],xy1[,2],xy2[,1], xy2[,2]) +x <- c(-100:0, 0:100, 100:0, 0:-100) / 10 +y <- c(0:100, 100:0, -(0:100), -(100:0)) / 10 +xy1 <- calcCoordsBorders(x, y) +xy2 <- calcCoordsBorders(x, y, xm = 1.2, ym = 1.2) +plot(xy2[, 1], xy2[, 2], type = "n") +segments(xy1[, 1], xy1[, 2], xy2[, 1], xy2[, 2]) } } diff --git a/man/cascade.Rd b/man/cascade.Rd index 105088dc..49a5f494 100644 --- a/man/cascade.Rd +++ b/man/cascade.Rd @@ -22,8 +22,9 @@ the midpoint and descend afterwards again. } \examples{ \dontrun{ - for(n in 1:10) - print(cascade(n)) +for (n in 1:10) { + print(cascade(n)) +} } } \keyword{internal} diff --git a/man/center.Rd b/man/center.Rd index d80d4f34..d3604e3d 100644 --- a/man/center.Rd +++ b/man/center.Rd @@ -27,9 +27,9 @@ centering the standard representation mode does not work any more as it remains attach to the centered values. } \examples{ - center(bell2010) # no centering - center(bell2010, rows=T) # row centering of grid - center(bell2010, cols=T) # column centering of grid - center(bell2010, rows=T, cols=T) # row and column centering +center(bell2010) # no centering +center(bell2010, rows = T) # row centering of grid +center(bell2010, cols = T) # column centering of grid +center(bell2010, rows = T, cols = T) # row and column centering } diff --git a/man/clearRatings.Rd b/man/clearRatings.Rd index c41d81ec..ebc6f93d 100644 --- a/man/clearRatings.Rd +++ b/man/clearRatings.Rd @@ -24,7 +24,7 @@ set certain ratings in grid to NA (unknown) \examples{ \dontrun{ - #### TODO #### +#### TODO #### } } \keyword{internal} diff --git a/man/cluster.Rd b/man/cluster.Rd index 95ad41cc..c96e4f88 100644 --- a/man/cluster.Rd +++ b/man/cluster.Rd @@ -72,14 +72,14 @@ optimal clustering. This approach is akin to the procedure used in FOCUS (Jankow } \examples{ - cluster(bell2010) - cluster(bell2010, main="My cluster analysis") # new title - cluster(bell2010, type="t") # different drawing style - cluster(bell2010, dmethod="manhattan") # using manhattan metric - cluster(bell2010, cmethod="single") # do single linkage clustering - cluster(bell2010, cex=1, lab.cex=1) # change appearance - cluster(bell2010, lab.cex=.7, edgePar=list(lty=1:2, col=2:1)) # advanced appearance changes - +cluster(bell2010) +cluster(bell2010, main = "My cluster analysis") # new title +cluster(bell2010, type = "t") # different drawing style +cluster(bell2010, dmethod = "manhattan") # using manhattan metric +cluster(bell2010, cmethod = "single") # do single linkage clustering +cluster(bell2010, cex = 1, lab.cex = 1) # change appearance +cluster(bell2010, lab.cex = .7, edgePar = list(lty = 1:2, col = 2:1)) # advanced appearance changes + } \references{ Jankowicz, D., & Thomas, L. (1982). An Algorithm for the Cluster Analysis of Repertory Grids in Human Resource diff --git a/man/clusterBoot.Rd b/man/clusterBoot.Rd index d239c1d8..60829c76 100644 --- a/man/clusterBoot.Rd +++ b/man/clusterBoot.Rd @@ -79,18 +79,18 @@ optimal clustering. This approach is akin to the procedure used in FOCUS (Jankow \examples{ \dontrun{ - # pvclust must be loaded - library(pvclust) - - # p-values for construct dendrogram - s <- clusterBoot(boeker) - plot(s) - pvrect(s, max.only=FALSE) - - # p-values for element dendrogram - s <- clusterBoot(boeker, along=2) - plot(s) - pvrect(s, max.only=FALSE) +# pvclust must be loaded +library(pvclust) + +# p-values for construct dendrogram +s <- clusterBoot(boeker) +plot(s) +pvrect(s, max.only = FALSE) + +# p-values for element dendrogram +s <- clusterBoot(boeker, along = 2) +plot(s) +pvrect(s, max.only = FALSE) } } diff --git a/man/constructCor.Rd b/man/constructCor.Rd index 2b47b5aa..23dbf57b 100644 --- a/man/constructCor.Rd +++ b/man/constructCor.Rd @@ -35,22 +35,22 @@ PMC, Kendall tau rank correlation, Spearman rank correlation. } \examples{ - # three different types of correlations - constructCor(mackay1992) - constructCor(mackay1992, method="kendall") - constructCor(mackay1992, method="spearman") - - # format output - constructCor(mackay1992, trim=6) - constructCor(mackay1992, index=TRUE, trim=6) - - # save correlation matrix for further processing - r <- constructCor(mackay1992) - r - print(r, digits=5) - - # accessing the correlation matrix - r[1, 3] +# three different types of correlations +constructCor(mackay1992) +constructCor(mackay1992, method = "kendall") +constructCor(mackay1992, method = "spearman") + +# format output +constructCor(mackay1992, trim = 6) +constructCor(mackay1992, index = TRUE, trim = 6) + +# save correlation matrix for further processing +r <- constructCor(mackay1992) +r +print(r, digits = 5) + +# accessing the correlation matrix +r[1, 3] } \seealso{ diff --git a/man/constructD.Rd b/man/constructD.Rd index 163d34c0..1e21f825 100644 --- a/man/constructD.Rd +++ b/man/constructD.Rd @@ -41,20 +41,19 @@ The direction of dependency needs to be specified. \examples{ \dontrun{ - constructD(fbb2003) # columns as dependent (default) - constructD(fbb2003, "c") # row as dependent - constructD(fbb2003, "s") # symmetrical index - - # suppress printing - d <- constructD(fbb2003, out=0, trim=5) - d - - # more digits - constructD(fbb2003, dig=3) +constructD(fbb2003) # columns as dependent (default) +constructD(fbb2003, "c") # row as dependent +constructD(fbb2003, "s") # symmetrical index - # add index column, no trimming - constructD(fbb2003, col.index=TRUE, index=F, trim=NA) +# suppress printing +d <- constructD(fbb2003, out = 0, trim = 5) +d +# more digits +constructD(fbb2003, dig = 3) + +# add index column, no trimming +constructD(fbb2003, col.index = TRUE, index = F, trim = NA) } } diff --git a/man/constructPca.Rd b/man/constructPca.Rd index d685e68d..782aad23 100644 --- a/man/constructPca.Rd +++ b/man/constructPca.Rd @@ -34,25 +34,25 @@ of factors has to be specified. For more information on the PCA function itself } \examples{ - constructPca(bell2010) +constructPca(bell2010) - # data from grid manual by Fransella et al. (2003, p. 87) - # note that the construct order is different - constructPca(fbb2003, nfactors=2) +# data from grid manual by Fransella et al. (2003, p. 87) +# note that the construct order is different +constructPca(fbb2003, nfactors = 2) - # no rotation - constructPca(fbb2003, rotate="none") +# no rotation +constructPca(fbb2003, rotate = "none") - # use a different type of correlation (Spearman) - constructPca(fbb2003, method="spearman") +# use a different type of correlation (Spearman) +constructPca(fbb2003, method = "spearman") - # save output to object - m <- constructPca(fbb2003, nfactors=2) - m +# save output to object +m <- constructPca(fbb2003, nfactors = 2) +m - # different printing options - print(m, digits=5) - print(m, cutoff=.3) +# different printing options +print(m, digits = 5) +print(m, cutoff = .3) } \references{ diff --git a/man/constructPcaLoadings.Rd b/man/constructPcaLoadings.Rd index 2eba26de..495d636e 100644 --- a/man/constructPcaLoadings.Rd +++ b/man/constructPcaLoadings.Rd @@ -17,10 +17,10 @@ Extract loadings from PCA of constructs. } \examples{ - p <- constructPca(bell2010) - l <- constructPcaLoadings(p) - l[1, ] - l[, 1] - l[1,1] - +p <- constructPca(bell2010) +l <- constructPcaLoadings(p) +l[1, ] +l[, 1] +l[1, 1] + } diff --git a/man/constructRmsCor.Rd b/man/constructRmsCor.Rd index f1589d17..9d5902d2 100644 --- a/man/constructRmsCor.Rd +++ b/man/constructRmsCor.Rd @@ -32,13 +32,13 @@ Bell & Bannister, 2003, p. 86). } \examples{ - # data from grid manual by Fransella, Bell and Bannister - constructRmsCor(fbb2003) - constructRmsCor(fbb2003, trim=20) - - # modify output - r <- constructRmsCor(fbb2003) - print(r, digits=5) +# data from grid manual by Fransella, Bell and Bannister +constructRmsCor(fbb2003) +constructRmsCor(fbb2003, trim = 20) + +# modify output +r <- constructRmsCor(fbb2003) +print(r, digits = 5) # access calculation results r[2, 1] diff --git a/man/constructs.Rd b/man/constructs.Rd index 1907c22e..8e5f6139 100644 --- a/man/constructs.Rd +++ b/man/constructs.Rd @@ -45,23 +45,23 @@ and \code{eNames} which are deprecated. x <- boeker ## get construct poles -constructs(x) # both left and right poles -leftpoles(x) # left poles only +constructs(x) # both left and right poles +leftpoles(x) # left poles only rightpoles(x) constructs(x, collapse = TRUE) ## replace construct poles -constructs(x)[1,1] <- "left pole 1" -constructs(x)[1,"leftpole"] <- "left pole 1" # alternative -constructs(x)[1:3,2] <- paste("right pole", 1:3) -constructs(x)[1:3,"rightpole"] <- paste("right pole", 1:3) # alternative -constructs(x)[4,1:2] <- c("left pole 4", "right pole 4") +constructs(x)[1, 1] <- "left pole 1" +constructs(x)[1, "leftpole"] <- "left pole 1" # alternative +constructs(x)[1:3, 2] <- paste("right pole", 1:3) +constructs(x)[1:3, "rightpole"] <- paste("right pole", 1:3) # alternative +constructs(x)[4, 1:2] <- c("left pole 4", "right pole 4") l <- leftpoles(x) -leftpoles(x) <- sample(l) # brind poles into random order -leftpoles(x)[1] <- "new left pole 1" # replace name of first left pole +leftpoles(x) <- sample(l) # brind poles into random order +leftpoles(x)[1] <- "new left pole 1" # replace name of first left pole # replace left poles of constructs 1 and 3 -leftpoles(x)[c(1,3)] <- c("new left pole 1", "new left pole 3") - +leftpoles(x)[c(1, 3)] <- c("new left pole 1", "new left pole 3") + } diff --git a/man/data-bell2010.Rd b/man/data-bell2010.Rd index c118fd54..d3a0aaa1 100644 --- a/man/data-bell2010.Rd +++ b/man/data-bell2010.Rd @@ -14,9 +14,9 @@ demonstrate the effects of construct alignment in Bell (2010, p. 46). Bell, R. C. (2010). A note on aligning constructs. \emph{Personal Construct Theory and Practice}, 7, 43-48. -\if{html}{\out{
}}\preformatted{ Haritos, A., Gindidis, A., Doan, C., & Bell, R. C. (2004). - The effect of element role titles on construct structure - and content. *Journal of constructivist +\if{html}{\out{
}}\preformatted{ Haritos, A., Gindidis, A., Doan, C., & Bell, R. C. (2004). + The effect of element role titles on construct structure + and content. *Journal of constructivist psychology, 17*(3), 221-236. }\if{html}{\out{
}} } diff --git a/man/data-bellmcgorry1992.Rd b/man/data-bellmcgorry1992.Rd index 07d03084..e0779bbd 100644 --- a/man/data-bellmcgorry1992.Rd +++ b/man/data-bellmcgorry1992.Rd @@ -15,10 +15,10 @@ Bell, R. C. (1977). \emph{Using SPSS to Analyse Repertory Grid Data}. Technical Report, University of Melbourne. -\if{html}{\out{
}}\preformatted{ Bell, R. C., & McGorry, P. (1992). The analysis of repertory - grids used to monitor the perceptions of recovering psychotic - patients. In A. Thomson & P. Cummins (Eds.), *European Perspectives - in Personal Construct Psychology* (p. 137-150). +\if{html}{\out{
}}\preformatted{ Bell, R. C., & McGorry, P. (1992). The analysis of repertory + grids used to monitor the perceptions of recovering psychotic + patients. In A. Thomson & P. Cummins (Eds.), *European Perspectives + in Personal Construct Psychology* (p. 137-150). Lincoln, UK: European Personal Construct Association. }\if{html}{\out{
}} } diff --git a/man/data-slater1977b.Rd b/man/data-slater1977b.Rd index 35959a88..10e297b3 100644 --- a/man/data-slater1977b.Rd +++ b/man/data-slater1977b.Rd @@ -14,7 +14,7 @@ herself. The data was originally reported by Watson (1970). Slater, P. (1977). \emph{The measurement of intrapersonal space by grid technique}. London: Wiley. -\if{html}{\out{
}}\preformatted{ Watson, J. P. (1970). The relationship between a self-mutilating +\if{html}{\out{
}}\preformatted{ Watson, J. P. (1970). The relationship between a self-mutilating patient and her doctor. *Psychotherapy and Psychosomatics, 18*(1), 67-73. }\if{html}{\out{
}} diff --git a/man/dim.repgrid.Rd b/man/dim.repgrid.Rd index dea86090..dab82495 100644 --- a/man/dim.repgrid.Rd +++ b/man/dim.repgrid.Rd @@ -20,8 +20,7 @@ two containing the number of constructs and elements. \examples{ \dontrun{ - dim(bell2010) - +dim(bell2010) } } diff --git a/man/distance.Rd b/man/distance.Rd index 63f05bb1..d26c7e70 100644 --- a/man/distance.Rd +++ b/man/distance.Rd @@ -54,27 +54,27 @@ Various distance measures between elements or constructs are calculated. } \examples{ - # between constructs - distance(bell2010, along = 1) - distance(bell2010, along = 1, normalize = TRUE) - - # between elements - distance(bell2010, along = 2) - - # several distance methods - distance(bell2010, dm = "man") # manhattan distance - distance(bell2010, dm = "mink", p = 3) # minkowski metric to the power of 3 +# between constructs +distance(bell2010, along = 1) +distance(bell2010, along = 1, normalize = TRUE) - # to save the results without printing to the console - d <- distance(bell2010, trim = 7) - d - - # some more options when printing the distance matrix - print(d, digits = 5) - print(d, col.index = FALSE) - print(d, upper = FALSE) - - # accessing entries from the matrix - d[1,3] +# between elements +distance(bell2010, along = 2) + +# several distance methods +distance(bell2010, dm = "man") # manhattan distance +distance(bell2010, dm = "mink", p = 3) # minkowski metric to the power of 3 + +# to save the results without printing to the console +d <- distance(bell2010, trim = 7) +d + +# some more options when printing the distance matrix +print(d, digits = 5) +print(d, col.index = FALSE) +print(d, upper = FALSE) + +# accessing entries from the matrix +d[1, 3] } diff --git a/man/distanceHartmann.Rd b/man/distanceHartmann.Rd index 0be3f11a..527c8a3c 100644 --- a/man/distanceHartmann.Rd +++ b/man/distanceHartmann.Rd @@ -82,29 +82,29 @@ Where \eqn{D_{slater}}{D_slater} denotes the Slater distances of the grid, \examples{ \dontrun{ - ### basics ### - - distanceHartmann(bell2010) - distanceHartmann(bell2010, method="simulate") - h <- distanceHartmann(bell2010, method="simulate") - h - - # printing options - print(h) - print(h, digits=6) - # 'significant' distances only - print(h, p=c(.05, .95)) - - # access cells of distance matrix - h[1,2] - - ### advanced ### - - # histogram of Slater distances and indifference region - h <- distanceHartmann(bell2010, distributions=TRUE) - l <- attr(h, "distributions") - hist(l$slater, breaks=100) - hist(l$hartmann, breaks=100) +### basics ### + +distanceHartmann(bell2010) +distanceHartmann(bell2010, method = "simulate") +h <- distanceHartmann(bell2010, method = "simulate") +h + +# printing options +print(h) +print(h, digits = 6) +# 'significant' distances only +print(h, p = c(.05, .95)) + +# access cells of distance matrix +h[1, 2] + +### advanced ### + +# histogram of Slater distances and indifference region +h <- distanceHartmann(bell2010, distributions = TRUE) +l <- attr(h, "distributions") +hist(l$slater, breaks = 100) +hist(l$hartmann, breaks = 100) } } diff --git a/man/distanceNormalized.Rd b/man/distanceNormalized.Rd index 996a81d1..b778910f 100644 --- a/man/distanceNormalized.Rd +++ b/man/distanceNormalized.Rd @@ -79,28 +79,27 @@ Kosmidis. \examples{ \dontrun{ - ### basics ### - - distanceNormalized(bell2010) - n <- distanceNormalized(bell2010) - n - - # printing options - print(n) - print(n, digits=4) - # 'significant' distances only - print(n, p=c(.05, .95)) - - # access cells of distance matrix - n[1,2] - - ### advanced ### - - # histogram of Slater distances and indifference region - n <- distanceNormalized(bell2010, distributions=TRUE) - l <- attr(n, "distributions") - hist(l$bc, breaks=100) - +### basics ### + +distanceNormalized(bell2010) +n <- distanceNormalized(bell2010) +n + +# printing options +print(n) +print(n, digits = 4) +# 'significant' distances only +print(n, p = c(.05, .95)) + +# access cells of distance matrix +n[1, 2] + +### advanced ### + +# histogram of Slater distances and indifference region +n <- distanceNormalized(bell2010, distributions = TRUE) +l <- attr(n, "distributions") +hist(l$bc, breaks = 100) } } diff --git a/man/distanceSlater.Rd b/man/distanceSlater.Rd index 7ce1d2a3..03019a77 100644 --- a/man/distanceSlater.Rd +++ b/man/distanceSlater.Rd @@ -50,15 +50,15 @@ The standardized Slater distances is the matrix of Euclidean distances \examples{ - distanceSlater(bell2010) - distanceSlater(bell2010, trim=40) +distanceSlater(bell2010) +distanceSlater(bell2010, trim = 40) - d <- distanceSlater(bell2010) - print(d) - print(d, digits=4) - - # using Norris and Makhlouf-Norris (problematic) cutoffs - print(d, cutoffs=c(.8, 1.2)) +d <- distanceSlater(bell2010) +print(d) +print(d, digits = 4) + +# using Norris and Makhlouf-Norris (problematic) cutoffs +print(d, cutoffs = c(.8, 1.2)) } \references{ diff --git a/man/doRectanglesOverlap.Rd b/man/doRectanglesOverlap.Rd index 981a02fb..146ab5a0 100644 --- a/man/doRectanglesOverlap.Rd +++ b/man/doRectanglesOverlap.Rd @@ -19,29 +19,29 @@ The overlap is assessed in x AND y. } \examples{ \dontrun{ - #overlap in x and y - a <- c(0,0,2,2) - b <- c(1,1,4,3) - plot(c(a,b), c(a,b), type="n") - rect(a[1], a[2], a[3], a[4]) - rect(b[1], b[2], b[3], b[4]) - doRectanglesOverlap(a,b) +# overlap in x and y +a <- c(0, 0, 2, 2) +b <- c(1, 1, 4, 3) +plot(c(a, b), c(a, b), type = "n") +rect(a[1], a[2], a[3], a[4]) +rect(b[1], b[2], b[3], b[4]) +doRectanglesOverlap(a, b) - # b contained in a vertically - a <- c(5,0,20,20) - b <- c(0, 5,15,15) - plot(c(a,b), c(a,b), type="n") - rect(a[1], a[2], a[3], a[4]) - rect(b[1], b[2], b[3], b[4]) - doRectanglesOverlap(a,b) +# b contained in a vertically +a <- c(5, 0, 20, 20) +b <- c(0, 5, 15, 15) +plot(c(a, b), c(a, b), type = "n") +rect(a[1], a[2], a[3], a[4]) +rect(b[1], b[2], b[3], b[4]) +doRectanglesOverlap(a, b) - # overlap only in y - a <- c(0,0,2,2) - b <- c(2.1,1,4,3) - plot(c(a,b), c(a,b), type="n") - rect(a[1], a[2], a[3], a[4]) - rect(b[1], b[2], b[3], b[4]) - doRectanglesOverlap(a,b) +# overlap only in y +a <- c(0, 0, 2, 2) +b <- c(2.1, 1, 4, 3) +plot(c(a, b), c(a, b), type = "n") +rect(a[1], a[2], a[3], a[4]) +rect(b[1], b[2], b[3], b[4]) +doRectanglesOverlap(a, b) } } diff --git a/man/doubleEntry.Rd b/man/doubleEntry.Rd index b969838e..37480753 100644 --- a/man/doubleEntry.Rd +++ b/man/doubleEntry.Rd @@ -18,8 +18,8 @@ Join the constructs of a grid with the same reversed constructs. \examples{ \dontrun{ - data(bell2010) - doubleEntry(bell2010) +data(bell2010) +doubleEntry(bell2010) } } diff --git a/man/elementCor.Rd b/man/elementCor.Rd index 1a45e47d..497bf9b0 100644 --- a/man/elementCor.Rd +++ b/man/elementCor.Rd @@ -29,26 +29,26 @@ reflection (Mackay, 1992; Bell, 2010). A correlation index invariant to construc (1969), which can be calculated using the argument \code{rc=TRUE} which is the default option. } \examples{ - elementCor(mackay1992) # Cohen's rc - elementCor(mackay1992, rc=FALSE) # PM correlation - elementCor(mackay1992, rc=FALSE, method="spearman") # Spearman correlation +elementCor(mackay1992) # Cohen's rc +elementCor(mackay1992, rc = FALSE) # PM correlation +elementCor(mackay1992, rc = FALSE, method = "spearman") # Spearman correlation - # format output - elementCor(mackay1992, trim=6) - elementCor(mackay1992, index=FALSE, trim=6) +# format output +elementCor(mackay1992, trim = 6) +elementCor(mackay1992, index = FALSE, trim = 6) - # save as object for further processing - r <- elementCor(mackay1992) - r +# save as object for further processing +r <- elementCor(mackay1992) +r - # change output of object - print(r, digits=5) - print(r, col.index=FALSE) - print(r, upper=FALSE) +# change output of object +print(r, digits = 5) +print(r, col.index = FALSE) +print(r, upper = FALSE) + +# accessing elements of the correlation matrix +r[1, 3] - # accessing elements of the correlation matrix - r[1,3] - } \references{ Bell, R. C. (2010). A note on aligning constructs. diff --git a/man/elementRmsCor.Rd b/man/elementRmsCor.Rd index 385bc782..0be97d61 100644 --- a/man/elementRmsCor.Rd +++ b/man/elementRmsCor.Rd @@ -38,16 +38,16 @@ reflection (Mackay, 1992; Bell, 2010). A correlation index invariant to construc } \examples{ - # data from grid manual by Fransella, Bell and Bannister - elementRmsCor(fbb2003) - elementRmsCor(fbb2003, trim=10) - - # modify output - r <- elementRmsCor(fbb2003) - print(r, digits=5) +# data from grid manual by Fransella, Bell and Bannister +elementRmsCor(fbb2003) +elementRmsCor(fbb2003, trim = 10) - # access second row of calculation results - r[2, "RMS"] +# modify output +r <- elementRmsCor(fbb2003) +print(r, digits = 5) + +# access second row of calculation results +r[2, "RMS"] } \references{ diff --git a/man/elements.Rd b/man/elements.Rd index 9601aff6..b1797859 100644 --- a/man/elements.Rd +++ b/man/elements.Rd @@ -31,10 +31,10 @@ e <- elements(x) e ## replace element names -elements(x) <- rev(e) # reverse all element names -elements(x)[1] <- "Hannes" # replace name of first element +elements(x) <- rev(e) # reverse all element names +elements(x)[1] <- "Hannes" # replace name of first element # replace names of elements 1 and 3 -elements(x)[c(1,3)] <- c("element 1", "element 3") - +elements(x)[c(1, 3)] <- c("element 1", "element 3") + } diff --git a/man/extract-methods.Rd b/man/extract-methods.Rd index 842cfb72..1daa0265 100644 --- a/man/extract-methods.Rd +++ b/man/extract-methods.Rd @@ -20,10 +20,10 @@ Methods for \code{"["}, i.e., subsetting of repgrid objects. } \examples{ - x <- randomGrid() - x[1:4, ] - x[ , 1:3] - x[1:4,1:3] - x[1,1] +x <- randomGrid() +x[1:4, ] +x[, 1:3] +x[1:4, 1:3] +x[1, 1] } diff --git a/man/getConstructNames2.Rd b/man/getConstructNames2.Rd index 0d369582..de65af3c 100644 --- a/man/getConstructNames2.Rd +++ b/man/getConstructNames2.Rd @@ -47,12 +47,11 @@ allow to return the kind of format that is needed. } \examples{ \dontrun{ - - getConstructNames2(bell2010) - getConstructNames2(bell2010, mode=2) - getConstructNames2(bell2010, index=T) - getConstructNames2(bell2010, index=T, mode=3) +getConstructNames2(bell2010) +getConstructNames2(bell2010, mode = 2) +getConstructNames2(bell2010, index = T) +getConstructNames2(bell2010, index = T, mode = 3) } } diff --git a/man/getElementNames2.Rd b/man/getElementNames2.Rd index f29785ca..1c349646 100644 --- a/man/getElementNames2.Rd +++ b/man/getElementNames2.Rd @@ -33,12 +33,11 @@ allow to return the kind of format that is needed. } \examples{ \dontrun{ - - getElementNames2(bell2010) - getElementNames2(bell2010, mode=2) - getElementNames2(bell2010, index=T) - getElementNames2(bell2010, index=T, trim=30) +getElementNames2(bell2010) +getElementNames2(bell2010, mode = 2) +getElementNames2(bell2010, index = T) +getElementNames2(bell2010, index = T, trim = 30) } } diff --git a/man/getNoOfConstructs.Rd b/man/getNoOfConstructs.Rd index fa2eaabb..536fc207 100644 --- a/man/getNoOfConstructs.Rd +++ b/man/getNoOfConstructs.Rd @@ -18,7 +18,7 @@ Get number of constructs \examples{ \dontrun{ - getNoOfConstructs(bell2010) +getNoOfConstructs(bell2010) } } diff --git a/man/getNoOfElements.Rd b/man/getNoOfElements.Rd index f9091af0..056d2689 100644 --- a/man/getNoOfElements.Rd +++ b/man/getNoOfElements.Rd @@ -18,7 +18,7 @@ Get number of elements \examples{ \dontrun{ - getNoOfElements(bell2010) +getNoOfElements(bell2010) } } diff --git a/man/getRatingLayer.Rd b/man/getRatingLayer.Rd index a9805268..1738620f 100644 --- a/man/getRatingLayer.Rd +++ b/man/getRatingLayer.Rd @@ -26,7 +26,7 @@ get rating layer \examples{ \dontrun{ - getRatingLayer(bell2010) +getRatingLayer(bell2010) } } diff --git a/man/getScaleMidpoint.Rd b/man/getScaleMidpoint.Rd index 3531b713..24d74293 100644 --- a/man/getScaleMidpoint.Rd +++ b/man/getScaleMidpoint.Rd @@ -18,8 +18,7 @@ Get midpoint of the grid rating scale \examples{ \dontrun{ - getScaleMidpoint(bell2010) - +getScaleMidpoint(bell2010) } } diff --git a/man/home.Rd b/man/home.Rd index 5b6adbae..97c059c7 100644 --- a/man/home.Rd +++ b/man/home.Rd @@ -26,12 +26,11 @@ pointing out of the screen. \examples{ \dontrun{ - biplot3d(boeker) - home(2) - home(3) - home(1) - home(theta=45, phi=45) - +biplot3d(boeker) +home(2) +home(3) +home(1) +home(theta = 45, phi = 45) } } diff --git a/man/importExcel.Rd b/man/importExcel.Rd index e8f2203f..920ae508 100644 --- a/man/importExcel.Rd +++ b/man/importExcel.Rd @@ -62,9 +62,8 @@ rg <- importExcel(file) system2("open", file) # Import more than one Excel file -files <- system.file("extdata", c("grid_01.xlsx", "grid_02.xlsx") , package = "OpenRepGrid") +files <- system.file("extdata", c("grid_01.xlsx", "grid_02.xlsx"), package = "OpenRepGrid") rg <- importExcel(files) - } } diff --git a/man/importGridcor.Rd b/man/importGridcor.Rd index 4f37208d..19f2e7a3 100644 --- a/man/importGridcor.Rd +++ b/man/importGridcor.Rd @@ -41,10 +41,8 @@ rg <- importGridcor(file, dir) # using a full path rg <- importGridcor("/Users/markheckmann/data/gridcor.dat") - } - } \references{ Feixas, G., & Cornejo, J. M. (2002). GRIDCOR: Correspondence Analysis diff --git a/man/importGridcorInternal.Rd b/man/importGridcorInternal.Rd index 5a79755e..c38a6159 100644 --- a/man/importGridcorInternal.Rd +++ b/man/importGridcorInternal.Rd @@ -19,7 +19,7 @@ Parse the file format that is used by the grid program GRIDCOR (Feixas & Cornejo } \note{ \if{html}{\out{
}}\preformatted{ Note that the GRIDCOR data sets the minimum ratings scale range to 1. - The maximum value can differ and is defined in the data file. + The maximum value can differ and is defined in the data file. }\if{html}{\out{
}} } \examples{ @@ -35,10 +35,8 @@ imp <- importGridcorInternal(file, dir) # using a full path imp <- importGridcorInternal("/Users/markheckmann/data/gridcor.dat") - } - } \references{ \url{https://www.ub.edu/terdep/gridcor.html} diff --git a/man/importGridstat.Rd b/man/importGridstat.Rd index b6d2583e..ec84cd4a 100644 --- a/man/importGridstat.Rd +++ b/man/importGridstat.Rd @@ -61,7 +61,7 @@ rg <- importGridstat(file, dir) rg <- importGridstat("/Users/markheckmann/data/gridstat.dat") # setting rating scale range -rg <- importGridstat(file, dir, min=1, max=6) +rg <- importGridstat(file, dir, min = 1, max = 6) } } diff --git a/man/importGridstatInternal.Rd b/man/importGridstatInternal.Rd index 93831972..a7c36ec6 100644 --- a/man/importGridstatInternal.Rd +++ b/man/importGridstatInternal.Rd @@ -28,38 +28,38 @@ Parse the file format that is used by the latest version of grid program gridstat (Bell, 1998). } \note{ -\if{html}{\out{
}}\preformatted{ Note that the gridstat data format does not contain explicit - information about the range of the rating scale (minimum and +\if{html}{\out{
}}\preformatted{ Note that the gridstat data format does not contain explicit + information about the range of the rating scale (minimum and maximum). By default the range is inferred by scanning the ratings and picking the minimal and maximal values as rating - range. You can set the minimal and maximal value by hand using the `min` and + range. You can set the minimal and maximal value by hand using the `min` and `max` arguments or by using the `setScale()` function. Note that if the rating range is not set, it may cause several functions to not work properly. A warning will be issued if the range is not set explicitly when using the importing function. - + The function only reads data from the latest GridStat version. The latest version allows the separation of the left and right pole by using on of the following symbols `/:-` (hyphen, colon and dash). Older versions may not - separate the left and right pole. This will cause all labels to be assigned to + separate the left and right pole. This will cause all labels to be assigned to the left pole only when importing. You may fix this by simply entering one of the construct separator symbols into the GridStat file between each left and right construct pole. The third line of a GridStat file may contain a no labels statement (i.e. a line containing any string of 'NOLA', 'NO L', 'NoLa', 'No L', 'Nola', 'No l', - 'nola' or 'no l'). In this case only ratings are supplied, hence, default + 'nola' or 'no l'). In this case only ratings are supplied, hence, default names are assigned to elements and constructs. - Email from Richard: The gridstat file has a fixed format with a title line, number - of constructs and elements on second line. The third line can say No labels + Email from Richard: The gridstat file has a fixed format with a title line, number + of constructs and elements on second line. The third line can say No labels (actually it looks at the first 4 characters which can be any of 'NOLA','NO L', - 'NoLa','No L','Nola','No l','nola','no l') in which case it skips to the data and - creates dummy labels for elements and constructs, otherwise it reads the construct - labels then the element labels, then the data. Construct labels were originally - stored as one, hence it didn't matter what the separator between left and right - pole labels was, but in the latest version where constructs can be reversed, it - looks for a fixed separator - one of slash(/), dash(-), or colon(:). Some of my + 'NoLa','No L','Nola','No l','nola','no l') in which case it skips to the data and + creates dummy labels for elements and constructs, otherwise it reads the construct + labels then the element labels, then the data. Construct labels were originally + stored as one, hence it didn't matter what the separator between left and right + pole labels was, but in the latest version where constructs can be reversed, it + looks for a fixed separator - one of slash(/), dash(-), or colon(:). Some of my old data files might not conform. }\if{html}{\out{
}} } @@ -78,7 +78,7 @@ imp <- importGridstatInternal(file, dir) imp <- importGridstatInternal("/Users/markheckmann/data/gridstat.dat") # setting rating scale range -imp <- importGridstatInternal(file, dir, min=1, max=6) +imp <- importGridstatInternal(file, dir, min = 1, max = 6) } } diff --git a/man/importGridsuite.Rd b/man/importGridsuite.Rd index 9d40617d..946900d9 100644 --- a/man/importGridsuite.Rd +++ b/man/importGridsuite.Rd @@ -41,10 +41,8 @@ rg <- importGridsuite(file, dir) # using a full path rg <- importGridsuite("/Users/markheckmann/data/gridsuite.xml") - } - } \references{ \url{http://www.gridsuite.de/} diff --git a/man/importGridsuiteInternal.Rd b/man/importGridsuiteInternal.Rd index 2d097a7c..a53f8b73 100644 --- a/man/importGridsuiteInternal.Rd +++ b/man/importGridsuiteInternal.Rd @@ -19,13 +19,13 @@ Internal parser for Gridsuite data files } \note{ \if{html}{\out{
}}\preformatted{ The developers of Gridsuite have proposed to use an XML scheme as - a standard exchange format for repertory grid data (Walter, - Bacher & Fromm, 2004). This approach is also embraced by the + a standard exchange format for repertory grid data (Walter, + Bacher & Fromm, 2004). This approach is also embraced by the `OpenRepGrid` package. }\if{html}{\out{
}} -\if{html}{\out{
}}\preformatted{ TODO: The element and construct IDs are not used yet. Thus, - if the output should be in different order the current mechanism +\if{html}{\out{
}}\preformatted{ TODO: The element and construct IDs are not used yet. Thus, + if the output should be in different order the current mechanism will cause false assignments. }\if{html}{\out{
}} } @@ -42,17 +42,15 @@ imp <- importGridsuite(file, dir) # using a full path imp <- importGridsuite("/Users/markheckmann/data/gridsuite.xml") - } - } \references{ \url{http://www.gridsuite.de/} -\if{html}{\out{
}}\preformatted{ Walter, O. B., Bacher, A., & Fromm, M. (2004). A proposal - for a common data exchange format for repertory grid data. - *Journal of Constructivist Psychology, 17*(3), 247. +\if{html}{\out{
}}\preformatted{ Walter, O. B., Bacher, A., & Fromm, M. (2004). A proposal + for a common data exchange format for repertory grid data. + *Journal of Constructivist Psychology, 17*(3), 247. doi:10.1080/10720530490447167 }\if{html}{\out{
}} } diff --git a/man/importScivesco.Rd b/man/importScivesco.Rd index dd621050..781cec1e 100644 --- a/man/importScivesco.Rd +++ b/man/importScivesco.Rd @@ -52,7 +52,6 @@ rg <- importScivesco(file, dir) # using a full path rg <- importScivesco("/Users/markheckmann/data/scivesco.scires") - } } \references{ diff --git a/man/importScivescoInternal.Rd b/man/importScivescoInternal.Rd index 71676d6a..0cc3ac57 100644 --- a/man/importScivescoInternal.Rd +++ b/man/importScivescoInternal.Rd @@ -23,23 +23,23 @@ Internal parser for sci:vesco files (suffix \code{scires}). \note{ \if{html}{\out{
}}\preformatted{ Sci:Vesco offers the options to rate the construct poles separately or using a bipolar scale. The separated rating is done using the "tetralemma" field. - The field is a bivariate plane on which each of the four (tetra) corners + The field is a bivariate plane on which each of the four (tetra) corners has a different meaning in terms of rating. Using this approach also allows ratings like: "both poles apply", "none of the poles apply" and all intermediate ratings can be chosen. This relaxes the bipolarity assumption often assumed in grid theory and allows for deviation from a strict bipolar rating if the constructs are not applied in a bipolar way. Using the tetralemma field for rating requires to analyze - each construct separately though. This means we get a double entry grid where the + each construct separately though. This means we get a double entry grid where the emergent and contrast pole ratings might not simply be a reflection of on another. - If a tetralemma field has been used for rating, `OpenRepGrid` offers the option + If a tetralemma field has been used for rating, `OpenRepGrid` offers the option to transform the scores into "normal" grid ratings (i.e. restricted to bipolarity) - by projecting the ratings from the bivariate tetralemma field onto the diagonal - of the tetralemma field and thus forcing a bipolar rating type. This option is + by projecting the ratings from the bivariate tetralemma field onto the diagonal + of the tetralemma field and thus forcing a bipolar rating type. This option is not recommended due to the fact that the conversion is susceptible to error when both ratings are near to zero. }\if{html}{\out{
}} -\if{html}{\out{
}}\preformatted{ TODO: The element IDs are not used yet. This might cause wrong assignments. +\if{html}{\out{
}}\preformatted{ TODO: The element IDs are not used yet. This might cause wrong assignments. }\if{html}{\out{
}} } \examples{ @@ -55,9 +55,7 @@ imp <- importScivescoInternal(file, dir) # using a full path imp <- importScivescoInternal("/Users/markheckmann/data/scivesco.scires") - } - } \keyword{internal} diff --git a/man/importTxtInternal.Rd b/man/importTxtInternal.Rd index c13dd441..8c7749cb 100644 --- a/man/importTxtInternal.Rd +++ b/man/importTxtInternal.Rd @@ -84,7 +84,6 @@ imp <- importTxtInternal(file, dir) # using a full path imp <- importTxtInternal("/Users/markheckmann/data/sample.txt") - } } diff --git a/man/indexBias.Rd b/man/indexBias.Rd index 2b37dbb0..6e143956 100644 --- a/man/indexBias.Rd +++ b/man/indexBias.Rd @@ -23,8 +23,8 @@ Numeric. STATUS: Working and checked against example in Slater, 1977, p. 87. } \examples{ - indexBias(boeker) - +indexBias(boeker) + } \references{ Slater, P. (1977). \emph{The measurement of intrapersonal space by Grid technique}. London: Wiley. diff --git a/man/indexConflict1.Rd b/man/indexConflict1.Rd index 65449994..2438ce86 100644 --- a/man/indexConflict1.Rd +++ b/man/indexConflict1.Rd @@ -42,9 +42,9 @@ The table below shows when a triad made up of the constructs A, B, and C is bala } } \examples{ - - indexConflict1(feixas2004) - indexConflict1(boeker) + +indexConflict1(feixas2004) +indexConflict1(boeker) } \references{ diff --git a/man/indexConflict2.Rd b/man/indexConflict2.Rd index a87f58cd..83ee564e 100644 --- a/man/indexConflict2.Rd +++ b/man/indexConflict2.Rd @@ -48,20 +48,20 @@ will make it more improbable that the relation will hold. \examples{ - indexConflict2(bell2010) - - x <- indexConflict2(bell2010) - print(x) - - # show conflictive triads - print(x, output = 2) - - # accessing the calculations for further use - x$total - x$imbalanced - x$prop.balanced - x$prop.imbalanced - x$triads.imbalanced +indexConflict2(bell2010) + +x <- indexConflict2(bell2010) +print(x) + +# show conflictive triads +print(x, output = 2) + +# accessing the calculations for further use +x$total +x$imbalanced +x$prop.balanced +x$prop.imbalanced +x$triads.imbalanced } \references{ diff --git a/man/indexConflict3.Rd b/man/indexConflict3.Rd index a77030aa..0b3b4fd0 100644 --- a/man/indexConflict3.Rd +++ b/man/indexConflict3.Rd @@ -85,23 +85,23 @@ Index of Conflict Variation. } \examples{ - # calculate conflicts - indexConflict3(bell2010) - - # show additional stats for elements 1 to 3 - indexConflict3(bell2010, e.out = 1:3) - - # show additional stats for constructs 1 and 5 - indexConflict3(bell2010, c.out = c(1,5)) - - # finetune output - ## change number of digits - x <- indexConflict3(bell2010) - print(x, digits = 4) +# calculate conflicts +indexConflict3(bell2010) - ## omit discrepancy matrices for constructs - x <- indexConflict3(bell2010, c.out = 5:6) - print(x, discrepancies = FALSE) +# show additional stats for elements 1 to 3 +indexConflict3(bell2010, e.out = 1:3) + +# show additional stats for constructs 1 and 5 +indexConflict3(bell2010, c.out = c(1, 5)) + +# finetune output +## change number of digits +x <- indexConflict3(bell2010) +print(x, digits = 4) + +## omit discrepancy matrices for constructs +x <- indexConflict3(bell2010, c.out = 5:6) +print(x, discrepancies = FALSE) } \references{ diff --git a/man/indexIntensity.Rd b/man/indexIntensity.Rd index 2efc6845..c114716d 100644 --- a/man/indexIntensity.Rd +++ b/man/indexIntensity.Rd @@ -47,25 +47,25 @@ the total is calculated as the unweighted average of all single scores (for elem \examples{ - indexIntensity(bell2010) - indexIntensity(bell2010, trim = NA) +indexIntensity(bell2010) +indexIntensity(bell2010, trim = NA) - # using Cohen's rc for element correlations - indexIntensity(bell2010, rc = TRUE) +# using Cohen's rc for element correlations +indexIntensity(bell2010, rc = TRUE) - # save output - x <- indexIntensity(bell2010) - x +# save output +x <- indexIntensity(bell2010) +x - # printing options - print(x, digits=4) +# printing options +print(x, digits = 4) - # accessing the objects' content - x$c.int - x$e.int - x$c.int.mean - x$e.int.mean - x$total.int +# accessing the objects' content +x$c.int +x$e.int +x$c.int.mean +x$e.int.mean +x$total.int } \references{ diff --git a/man/indexPvaff.Rd b/man/indexPvaff.Rd index a661a3ce..ead2078f 100644 --- a/man/indexPvaff.Rd +++ b/man/indexPvaff.Rd @@ -22,7 +22,7 @@ said to be low. In this case the construct system is regarded as 'simple' (Bell, } \examples{ - indexPvaff(bell2010) +indexPvaff(bell2010) } \references{ diff --git a/man/indexVariability.Rd b/man/indexVariability.Rd index 6925e7cb..141c9265 100644 --- a/man/indexVariability.Rd +++ b/man/indexVariability.Rd @@ -24,8 +24,7 @@ p.88). STATUS: working and checked against example in Slater, 1977 , p.88. } \examples{ - - indexVariability(boeker) +indexVariability(boeker) } \references{ diff --git a/man/lapply_pb.Rd b/man/lapply_pb.Rd index 8ac48908..7f48b895 100644 --- a/man/lapply_pb.Rd +++ b/man/lapply_pb.Rd @@ -23,9 +23,8 @@ it does is create an additional progress bar. \examples{ \dontrun{ - l <- sapply(1:20000, function(x) list(rnorm(1000))) - lapply_pb(l, mean) - +l <- sapply(1:20000, function(x) list(rnorm(1000))) +lapply_pb(l, mean) } } diff --git a/man/makeRepgrid.Rd b/man/makeRepgrid.Rd index 9d652c51..69f363b9 100644 --- a/man/makeRepgrid.Rd +++ b/man/makeRepgrid.Rd @@ -25,16 +25,20 @@ make a new grid (see parameters). \examples{ \dontrun{ - # make list object containing the arguments - args <- list( name=c("element_1", "element_2", "element_3", "element_4"), - l.name=c("left_1", "left_2", "left_3"), - r.name=c("right_1", "right_2", "right_3"), - scores=c( 1,0,1,0, - 1,1,1,0, - 1,0,1,0 ) ) - # make grid object - x <- makeRepgrid(args) - x +# make list object containing the arguments +args <- list( + name = c("element_1", "element_2", "element_3", "element_4"), + l.name = c("left_1", "left_2", "left_3"), + r.name = c("right_1", "right_2", "right_3"), + scores = c( + 1, 0, 1, 0, + 1, 1, 1, 0, + 1, 0, 1, 0 + ) +) +# make grid object +x <- makeRepgrid(args) +x } } diff --git a/man/map.Rd b/man/map.Rd index d58ee190..6c2fe958 100644 --- a/man/map.Rd +++ b/man/map.Rd @@ -19,11 +19,12 @@ map a value onto others } \examples{ \dontrun{ - map(1:10, 3) +map(1:10, 3) - m <- matrix(1:12, ncol=4) - for(i in 1:12) - print(m[ring(i, 3), map(i, 4)]) +m <- matrix(1:12, ncol = 4) +for (i in 1:12) { + print(m[ring(i, 3), map(i, 4)]) +} } } diff --git a/man/modifyConstruct.Rd b/man/modifyConstruct.Rd index e3115b11..c42c8094 100644 --- a/man/modifyConstruct.Rd +++ b/man/modifyConstruct.Rd @@ -44,7 +44,7 @@ change the attributes of a construct \examples{ \dontrun{ - #### TODO #### +#### TODO #### } } diff --git a/man/modifyElement.Rd b/man/modifyElement.Rd index bebaf398..3646eb85 100644 --- a/man/modifyElement.Rd +++ b/man/modifyElement.Rd @@ -35,7 +35,7 @@ change the attributes of an element i.e. name, abbreviation, status etc. \examples{ \dontrun{ - #### TODO #### +#### TODO #### } } \keyword{internal} diff --git a/man/move.Rd b/man/move.Rd index 4d41ec81..365d9f7e 100644 --- a/man/move.Rd +++ b/man/move.Rd @@ -37,10 +37,10 @@ Move element in grid to the right. } \examples{ \dontrun{ - x <- randomGrid() - left(x, 2) # 2nd element to the left - right(x, 1) # 1st element to the right - up(x, 2) # 2nd construct upwards - down(x, 1) # 1st construct downwards +x <- randomGrid() +left(x, 2) # 2nd element to the left +right(x, 1) # 1st element to the right +up(x, 2) # 2nd construct upwards +down(x, 1) # 1st construct downwards } } diff --git a/man/normalize.Rd b/man/normalize.Rd index 184f29c6..34cc92cb 100644 --- a/man/normalize.Rd +++ b/man/normalize.Rd @@ -22,8 +22,8 @@ Not yet defined TODO! Normalize rows or columns by its standard deviation. } \examples{ - x <- matrix(sample(1:5, 20, rep=TRUE), 4) - normalize(x, 1) # normalizing rows - normalize(x, 2) # normalizing columns +x <- matrix(sample(1:5, 20, rep = TRUE), 4) +normalize(x, 1) # normalizing rows +normalize(x, 2) # normalizing columns } diff --git a/man/ops-methods.Rd b/man/ops-methods.Rd index c8b127ae..eba6a3da 100644 --- a/man/ops-methods.Rd +++ b/man/ops-methods.Rd @@ -27,7 +27,7 @@ Methods for \code{"+"} function. x <- bell2010 x + x -x + list(x,x) -list(x,x) + x +x + list(x, x) +list(x, x) + x } diff --git a/man/orderByString.Rd b/man/orderByString.Rd index 5313bc03..dc046fde 100644 --- a/man/orderByString.Rd +++ b/man/orderByString.Rd @@ -19,11 +19,11 @@ find the order of a string vector so it will match the order of another } \examples{ \dontrun{ - a <- c("c", "a", "b") - b <- c("b", "c", "a") - index <- orderByString(a, b) # to order b like a needs what indexes? - index - b[index] +a <- c("c", "a", "b") +b <- c("b", "c", "a") +index <- orderByString(a, b) # to order b like a needs what indexes? +index +b[index] } } diff --git a/man/permuteConstructs.Rd b/man/permuteConstructs.Rd index 890a19cb..0ab08620 100644 --- a/man/permuteConstructs.Rd +++ b/man/permuteConstructs.Rd @@ -22,9 +22,8 @@ Generate a list with all possible construct reflections of a grid. \examples{ \dontrun{ - l <- permuteConstructs(mackay1992) - l - +l <- permuteConstructs(mackay1992) +l } } diff --git a/man/permuteGrid.Rd b/man/permuteGrid.Rd index 18c4eb47..42bd4e5b 100644 --- a/man/permuteGrid.Rd +++ b/man/permuteGrid.Rd @@ -25,15 +25,14 @@ the rows, the columns or the whole grid matrix. } \examples{ \dontrun{ - - # permute grid - permuteGrid(bell2010) - permuteGrid(bell2010) - permuteGrid(bell2010) - # generate a list of permuted grids - permuteGrid(bell2010, n=5) +# permute grid +permuteGrid(bell2010) +permuteGrid(bell2010) +permuteGrid(bell2010) +# generate a list of permuted grids +permuteGrid(bell2010, n = 5) } } diff --git a/man/prepareBiplotData.Rd b/man/prepareBiplotData.Rd index b0bc2788..9d7d609f 100644 --- a/man/prepareBiplotData.Rd +++ b/man/prepareBiplotData.Rd @@ -122,10 +122,10 @@ the current plane are shown. Set the value to \code{91} (default) to show all vectors.} } \value{ -\code{dataframe} containing the variables \verb{type, show, x, y, z, labels, color, cex}. Usually not of interest to the user. +\code{dataframe} containing the variables \verb{type, show, x, y, z, labels, color, cex}. Usually not of interest to the user. } \description{ -Data frame contains the variables \verb{type, show, x, y, z, labels, color, cex}. +Data frame contains the variables \verb{type, show, x, y, z, labels, color, cex}. } \note{ \if{html}{\out{
}}\preformatted{ TODO: How to omit `map.dim`? diff --git a/man/quasiDistributionDistanceSlater.Rd b/man/quasiDistributionDistanceSlater.Rd index c235ad50..a28aaa1b 100644 --- a/man/quasiDistributionDistanceSlater.Rd +++ b/man/quasiDistributionDistanceSlater.Rd @@ -37,12 +37,11 @@ distributions standard deviation. } \examples{ \dontrun{ - - vals <- quasiDistributionDistanceSlater(100, 10, 10, c(1,5), pro=T) - vals - sd(vals) - hist(vals, breaks=50) - + +vals <- quasiDistributionDistanceSlater(100, 10, 10, c(1, 5), pro = T) +vals +sd(vals) +hist(vals, breaks = 50) } } diff --git a/man/randomGrid.Rd b/man/randomGrid.Rd index 22532b1a..1549283d 100644 --- a/man/randomGrid.Rd +++ b/man/randomGrid.Rd @@ -42,12 +42,12 @@ exploring distributions of indexes etc. \examples{ \dontrun{ - x <- randomGrid() - x - x <- randomGrid(10, 25) - x - x <- randomGrid(10, 25, options=0) - x +x <- randomGrid() +x +x <- randomGrid(10, 25) +x +x <- randomGrid(10, 25, options = 0) +x } } diff --git a/man/randomGrids.Rd b/man/randomGrids.Rd index 8f4e5340..045295d0 100644 --- a/man/randomGrids.Rd +++ b/man/randomGrids.Rd @@ -46,12 +46,12 @@ simple wrapper around \code{\link[=randomGrid]{randomGrid()}}. \examples{ \dontrun{ - x <- randomGrids() - x - x <- randomGrids(5, 3, 3) - x - x <- randomGrids(5, 3, 3, options=0) - x +x <- randomGrids() +x +x <- randomGrids(5, 3, 3) +x +x <- randomGrids(5, 3, 3, options = 0) +x } } diff --git a/man/randomSentence.Rd b/man/randomSentence.Rd index 84a0ca59..c7e659d0 100644 --- a/man/randomSentence.Rd +++ b/man/randomSentence.Rd @@ -20,7 +20,6 @@ a string with n words (if length is not constrained) generate a random sentence with n words } \examples{ - -randomSentence(10) # one random sentence with 10 words +randomSentence(10) # one random sentence with 10 words } \keyword{internal} diff --git a/man/randomSentences.Rd b/man/randomSentences.Rd index 7ab668d0..4a127a43 100644 --- a/man/randomSentences.Rd +++ b/man/randomSentences.Rd @@ -23,7 +23,7 @@ a vector with n random sentences generate n random sentences with a given or random number of words } \examples{ -randomSentences(5, 10) # five random sentences with ten words each -randomSentences(5, 2:10) # five random sentences between two and ten words +randomSentences(5, 10) # five random sentences with ten words each +randomSentences(5, 2:10) # five random sentences between two and ten words } \keyword{internal} diff --git a/man/randomWords.Rd b/man/randomWords.Rd index 0d529a0d..fd2afb78 100644 --- a/man/randomWords.Rd +++ b/man/randomWords.Rd @@ -17,6 +17,6 @@ randomWords generates a vector of random words taken from a small set of words } \examples{ -randomWords(10) # 10 random words +randomWords(10) # 10 random words } \keyword{internal} diff --git a/man/ratings.Rd b/man/ratings.Rd index d8c75a0b..fb7fe18a 100644 --- a/man/ratings.Rd +++ b/man/ratings.Rd @@ -42,19 +42,19 @@ x <- bell2010 ratings(x) -## replace ratings - -ratings(x)[1,1] <- 1 +## replace ratings + +ratings(x)[1, 1] <- 1 # noet that this is even simpler using the repgrid object directly -x[1,1] <- 2 +x[1, 1] <- 2 -#replace several values +# replace several values -ratings(x)[1,1:5] <- 1 -x[1,1:5] <- 2 # the same +ratings(x)[1, 1:5] <- 1 +x[1, 1:5] <- 2 # the same -ratings(x)[1:3,5:6] <- matrix(5, 3, 2) -x[1:3,5:6] <- matrix(5, 3, 2) # the same +ratings(x)[1:3, 5:6] <- matrix(5, 3, 2) +x[1:3, 5:6] <- matrix(5, 3, 2) # the same ## ratings as dataframe in wide or long format diff --git a/man/recycle.Rd b/man/recycle.Rd index 1f092191..7751ce25 100644 --- a/man/recycle.Rd +++ b/man/recycle.Rd @@ -29,12 +29,12 @@ number of elements from vec, vec is cut off to make it usable for many purposes. } \examples{ -recycle(c(1,2,3), 7) -recycle(c(1,2,3), letters[1:7]) -recycle(c(1,2,3), 7, na.fill=TRUE) -recycle(1, letters[1:3], na.fill=TRUE) +recycle(c(1, 2, 3), 7) +recycle(c(1, 2, 3), letters[1:7]) +recycle(c(1, 2, 3), 7, na.fill = TRUE) +recycle(1, letters[1:3], na.fill = TRUE) recycle(letters[1:3], 7) -recycle(letters[1:3], letters[1:7]) -recycle(letters[1:40], letters[1:7]) # vec is cut off +recycle(letters[1:3], letters[1:7]) +recycle(letters[1:40], letters[1:7]) # vec is cut off } \keyword{internal} diff --git a/man/recycle2.Rd b/man/recycle2.Rd index 73874095..94c30bb2 100644 --- a/man/recycle2.Rd +++ b/man/recycle2.Rd @@ -25,7 +25,7 @@ longer one \examples{ recycle2(1:10, 1:3) recycle2(1, 1:5) -recycle2(1, 1:5, na.fill=TRUE) -recycle2(1:5, 5:1) # vectors unchanged +recycle2(1, 1:5, na.fill = TRUE) +recycle2(1:5, 5:1) # vectors unchanged } \keyword{internal} diff --git a/man/reorder.Rd b/man/reorder.Rd index 49ef73fb..c03d4b5d 100644 --- a/man/reorder.Rd +++ b/man/reorder.Rd @@ -18,7 +18,7 @@ elements (\code{"C"}, \code{1}), or both (\code{"CE"}, \code{12}) should be reve Invert construct and element order } \examples{ - + # invert order of constructs reorder(boeker, "C") reorder(boeker, 1) diff --git a/man/reorder2d.Rd b/man/reorder2d.Rd index 5aaae49c..01c1e320 100644 --- a/man/reorder2d.Rd +++ b/man/reorder2d.Rd @@ -55,9 +55,9 @@ identify circumplex structures in data indicated by the diagonal stripe in the d } \examples{ -x <- feixas2004 -reorder2d(x) # reorder grid by angles in first two dimensions -reorder2d(x, rc=FALSE) # reorder elements only -reorder2d(x, re=FALSE) # reorder constructs only +x <- feixas2004 +reorder2d(x) # reorder grid by angles in first two dimensions +reorder2d(x, rc = FALSE) # reorder elements only +reorder2d(x, re = FALSE) # reorder constructs only } diff --git a/man/reverse.Rd b/man/reverse.Rd index dbcf9051..345231d0 100644 --- a/man/reverse.Rd +++ b/man/reverse.Rd @@ -31,11 +31,11 @@ error is raised. x <- boeker -reverse(x) # reverse all constructs -reverse(x, 1) # reverse construct 1 -reverse(x, 1:2) # reverse constructs 1 and 2 +reverse(x) # reverse all constructs +reverse(x, 1) # reverse construct 1 +reverse(x, 1:2) # reverse constructs 1 and 2 # swapPoles will become deprecated, use reverse instead -swapPoles(x, 1) # swap construct poles of construct +swapPoles(x, 1) # swap construct poles of construct } diff --git a/man/ring.Rd b/man/ring.Rd index 8323ec86..26eff154 100644 --- a/man/ring.Rd +++ b/man/ring.Rd @@ -21,11 +21,12 @@ columns of a matrix if the } \examples{ \dontrun{ - ring(1:10, 3) +ring(1:10, 3) - m <- matrix(1:12, ncol=4) - for(i in 1:12) - print(m[ring(i, 3), map(i, 4)]) +m <- matrix(1:12, ncol = 4) +for (i in 1:12) { + print(m[ring(i, 3), map(i, 4)]) +} } } diff --git a/man/sapply_pb.Rd b/man/sapply_pb.Rd index 6493c217..2b07962c 100644 --- a/man/sapply_pb.Rd +++ b/man/sapply_pb.Rd @@ -23,14 +23,13 @@ it does is create an additional progress bar. \examples{ \dontrun{ - l <- sapply(1:20000, function(x) list(rnorm(1000))) - head(sapply_pb(l, mean)) - - # performance comparison - l <- sapply(1:20000, function(x) list(rnorm(1000))) - system.time(sapply(l, mean)) - system.time(sapply_pb(l, mean)) +l <- sapply(1:20000, function(x) list(rnorm(1000))) +head(sapply_pb(l, mean)) +# performance comparison +l <- sapply(1:20000, function(x) list(rnorm(1000))) +system.time(sapply(l, mean)) +system.time(sapply_pb(l, mean)) } } \seealso{ diff --git a/man/saveAsExcel.Rd b/man/saveAsExcel.Rd index 852b33ac..39b7b19a 100644 --- a/man/saveAsExcel.Rd +++ b/man/saveAsExcel.Rd @@ -24,9 +24,8 @@ Invisibly returns the name of the file. \examples{ \dontrun{ - x <- randomGrid(options=0) - saveAsExcel(x, "grid.xlsx") - +x <- randomGrid(options = 0) +saveAsExcel(x, "grid.xlsx") } } diff --git a/man/saveAsTxt.Rd b/man/saveAsTxt.Rd index 0f50723d..0300e5e5 100644 --- a/man/saveAsTxt.Rd +++ b/man/saveAsTxt.Rd @@ -58,9 +58,8 @@ Structure of a txt file that can be read by \code{\link[=importTxt]{importTxt()} \examples{ \dontrun{ - x <- randomGrid() - saveAsTxt(x, "random.txt") - +x <- randomGrid() +saveAsTxt(x, "random.txt") } } diff --git a/man/setConstructAttr.Rd b/man/setConstructAttr.Rd index 917c7cde..ef0ccac9 100644 --- a/man/setConstructAttr.Rd +++ b/man/setConstructAttr.Rd @@ -41,9 +41,11 @@ Set the attributes of a construct i.e. name, abbreviation, status etc. \examples{ \dontrun{ - x <- setConstructAttr(bell2010, 1, - "new left pole", "new right pole") - x +x <- setConstructAttr( + bell2010, 1, + "new left pole", "new right pole" +) +x } } diff --git a/man/setElementAttr.Rd b/man/setElementAttr.Rd index 89345c14..4132f0a0 100644 --- a/man/setElementAttr.Rd +++ b/man/setElementAttr.Rd @@ -25,15 +25,15 @@ are changed.} Set the attributes of an element i.e. name, abbreviation, status etc. } \note{ -\if{html}{\out{
}}\preformatted{ Currently the main purpose is to change element names. +\if{html}{\out{
}}\preformatted{ Currently the main purpose is to change element names. Future implementations will allow to set further attributes. }\if{html}{\out{
}} } \examples{ \dontrun{ - - x <- setElementAttr(boeker, 1, "new name") # change name of first element - x + +x <- setElementAttr(boeker, 1, "new name") # change name of first element +x } } diff --git a/man/setMeta.Rd b/man/setMeta.Rd index 1bd23e34..96347d3e 100644 --- a/man/setMeta.Rd +++ b/man/setMeta.Rd @@ -24,7 +24,7 @@ set meta data of a grid (e.g. id, name of interview partner) \examples{ \dontrun{ - #### TODO #### +#### TODO #### } } diff --git a/man/setScale.Rd b/man/setScale.Rd index b0eaaa74..b3d76923 100644 --- a/man/setScale.Rd +++ b/man/setScale.Rd @@ -28,11 +28,11 @@ a grid he should make sure that the scale range is set correctly. \examples{ \dontrun{ - x <- bell2010 - x <- setScale(x, 0, 8) # not set correctly - x - x <- setScale(x, 1, 7) # set correctly - x +x <- bell2010 +x <- setScale(x, 0, 8) # not set correctly +x +x <- setScale(x, 1, 7) # set correctly +x } } diff --git a/man/settings.Rd b/man/settings.Rd index 64c5c4ce..b5e47202 100644 --- a/man/settings.Rd +++ b/man/settings.Rd @@ -31,7 +31,7 @@ The default value is shown in the brackets at the end of a line. \examples{ \dontrun{ # get current settings -settings() +settings() # get some parameters settings("show.scale", "show.meta") @@ -39,10 +39,10 @@ settings("show.scale", "show.meta") # change parameters bell2010 -settings(show.meta=F) +settings(show.meta = F) bell2010 -settings(show.scale=F, show.cut=30) +settings(show.scale = F, show.cut = 30) bell2010 } diff --git a/man/shift.Rd b/man/shift.Rd index 70f0cbe4..391ade58 100644 --- a/man/shift.Rd +++ b/man/shift.Rd @@ -23,11 +23,11 @@ the same but the prompted element or construct appears in first position. \examples{ \dontrun{ - # shift element 13: 'Ideal self' to first position - shift(feixas2004, 13) +# shift element 13: 'Ideal self' to first position +shift(feixas2004, 13) - x <- randomGrid(5,10) - shift(x, 3, 5) +x <- randomGrid(5, 10) +shift(x, 3, 5) } } diff --git a/man/showMeta.Rd b/man/showMeta.Rd index 6524bb96..5cb640d7 100644 --- a/man/showMeta.Rd +++ b/man/showMeta.Rd @@ -18,7 +18,7 @@ prints meta information about the grid to the console (id, name of interviewee e \examples{ \dontrun{ - #### TODO #### +#### TODO #### } } diff --git a/man/showScale.Rd b/man/showScale.Rd index 1c21eb7b..51760065 100644 --- a/man/showScale.Rd +++ b/man/showScale.Rd @@ -18,8 +18,8 @@ Print scale range information to the console. \examples{ \dontrun{ - showScale(raeithel) - showScale(bell2010) +showScale(raeithel) +showScale(bell2010) } } diff --git a/man/ssq.Rd b/man/ssq.Rd index 5738e860..f7fe80da 100644 --- a/man/ssq.Rd +++ b/man/ssq.Rd @@ -62,26 +62,26 @@ each point are set in contrast with the pre-transformed matrix. } \examples{ - # explained sum-of-squares for elements - ssq(bell2010) +# explained sum-of-squares for elements +ssq(bell2010) - # explained sum-of-squares for constructs - ssq(bell2010, along=1) +# explained sum-of-squares for constructs +ssq(bell2010, along = 1) - # save results - s <- ssq(bell2010) +# save results +s <- ssq(bell2010) - # printing options - print(s) - print(s, digits=4) - print(s, dim=3) - print(s, cumulated=FALSE) +# printing options +print(s) +print(s, digits = 4) +print(s, dim = 3) +print(s, cumulated = FALSE) + +# access results +names(s) +s$ssq.table +s$ssq.table.cumsum +s$ssq.total - # access results - names(s) - s$ssq.table - s$ssq.table.cumsum - s$ssq.total - } \keyword{internal} diff --git a/man/stats.Rd b/man/stats.Rd index f8d38ac9..316a615b 100644 --- a/man/stats.Rd +++ b/man/stats.Rd @@ -43,23 +43,23 @@ type \code{?describe}. } \examples{ - statsConstructs(fbb2003) - statsConstructs(fbb2003, trim=10) - statsConstructs(fbb2003, trim=10, index=FALSE) +statsConstructs(fbb2003) +statsConstructs(fbb2003, trim = 10) +statsConstructs(fbb2003, trim = 10, index = FALSE) - statsElements(fbb2003) - statsElements(fbb2003, trim=10) - statsElements(fbb2003, trim=10, index=FALSE) +statsElements(fbb2003) +statsElements(fbb2003, trim = 10) +statsElements(fbb2003, trim = 10, index = FALSE) - # save the access the results - d <- statsElements(fbb2003) - d - d["mean"] - d[2, "mean"] # mean rating of 2nd element +# save the access the results +d <- statsElements(fbb2003) +d +d["mean"] +d[2, "mean"] # mean rating of 2nd element - d <- statsConstructs(fbb2003) - d - d["sd"] - d[1, "sd"] # sd of ratings on first construct +d <- statsConstructs(fbb2003) +d +d["sd"] +d[1, "sd"] # sd of ratings on first construct } diff --git a/man/stepChart.Rd b/man/stepChart.Rd index fd33864d..9a7652f7 100644 --- a/man/stepChart.Rd +++ b/man/stepChart.Rd @@ -23,10 +23,10 @@ for the heights. \examples{ \dontrun{ - x <- rnorm(1000) - y <- rnorm(1000, sd=.6) - stepChart(y, breaks=50) - stepChart(x, add=T, breaks=50, col="red") +x <- rnorm(1000) +y <- rnorm(1000, sd = .6) +stepChart(y, breaks = 50) +stepChart(x, add = T, breaks = 50, col = "red") } } diff --git a/man/subassign.Rd b/man/subassign.Rd index eab2878d..5ddf3439 100644 --- a/man/subassign.Rd +++ b/man/subassign.Rd @@ -21,17 +21,17 @@ It should be possible to use it for ratings on all layers. \examples{ \dontrun{ x <- randomGrid() -x[1,1] <- 2 +x[1, 1] <- 2 x[1, ] <- 4 -x[ ,2] <- 3 - -# settings values outside defined rating scale +x[, 2] <- 3 + +# settings values outside defined rating scale # range throws an error -x[1,1] <- 999 - +x[1, 1] <- 999 + # removing scale range allows arbitary values to be set -x <- setScale(x, min = NA, max=NA) -x[1,1] <- 999 +x <- setScale(x, min = NA, max = NA) +x[1, 1] <- 999 } } diff --git a/man/swapConstructs.Rd b/man/swapConstructs.Rd index d0a63b46..f0884025 100644 --- a/man/swapConstructs.Rd +++ b/man/swapConstructs.Rd @@ -22,9 +22,9 @@ Swap the position of two constructs in a grid. \examples{ \dontrun{ - x <- randomGrid() - swapConstructs(x, 1, 3) # swap constructs 1 and 3 - swapConstructs(x, 1:2, 3:4) # swap construct 1 with 3 and 2 with 4 +x <- randomGrid() +swapConstructs(x, 1, 3) # swap constructs 1 and 3 +swapConstructs(x, 1:2, 3:4) # swap construct 1 with 3 and 2 with 4 } } diff --git a/man/swapElements.Rd b/man/swapElements.Rd index 70535fab..719b05e2 100644 --- a/man/swapElements.Rd +++ b/man/swapElements.Rd @@ -21,9 +21,9 @@ Swap the position of two elements in a grid. } \examples{ \dontrun{ - x <- randomGrid() - swapElements(x, 1, 3) # swap elements 1 and 3 - swapElements(x, 1:2, 3:4) # swap element 1 with 3 and 2 with 4 +x <- randomGrid() +swapElements(x, 1, 3) # swap elements 1 and 3 +swapElements(x, 1:2, 3:4) # swap element 1 with 3 and 2 with 4 } } diff --git a/man/trim_val.Rd b/man/trim_val.Rd index 7bcf5238..eb580c25 100644 --- a/man/trim_val.Rd +++ b/man/trim_val.Rd @@ -24,7 +24,7 @@ by the boundary value or alternatively by NA } \examples{ trim_val(30) -trim_val(30, c(10,20)) +trim_val(30, c(10, 20)) } \keyword{internal} diff --git a/tests/testthat/test-basicops.R b/tests/testthat/test-basicops.R index 24b662e4..e4c0b07f 100644 --- a/tests/testthat/test-basicops.R +++ b/tests/testthat/test-basicops.R @@ -1,12 +1,11 @@ # basic operations test_that("addAvgElement works correctly", { - # average of one element yields same values x <- addAvgElement(feixas2004, "AVG", i = 1) - R <- ratings(x[, c(1,14)]) - expect_equal(R[, 1], R[, 2]) - + R <- ratings(x[, c(1, 14)]) + expect_equal(R[, 1], R[, 2]) + # error is thrown if i is out of range expect_error({ x <- addAvgElement(feixas2004, "AVG", i = 0) @@ -21,31 +20,28 @@ test_that("addAvgElement works correctly", { expect_error({ x <- addAvgElement(feixas2004, "Mother", i = 1:16) }) - - # duplicate indexes generate warning + + # duplicate indexes generate warning expect_warning({ - x <- addAvgElement(feixas2004, "AVG", i = c(1,1,2)) + x <- addAvgElement(feixas2004, "AVG", i = c(1, 1, 2)) }) }) test_that("stop_if_not_is_repgrid works correctly", { - expect_error( - stop_if_not_is_repgrid("a") + stop_if_not_is_repgrid("a") ) - + expect_error( - stop_if_not_is_repgrid("a", "some_name") + stop_if_not_is_repgrid("a", "some_name") ) }) - -test_that("reverse works correctly", { - expect_equal(swapPoles(boeker), reverse(boeker) ) - - ii <- c(1,4,6) - expect_equal(swapPoles(boeker, ii), reverse(boeker, ii) ) -}) +test_that("reverse works correctly", { + expect_equal(swapPoles(boeker), reverse(boeker)) + ii <- c(1, 4, 6) + expect_equal(swapPoles(boeker, ii), reverse(boeker, ii)) +}) diff --git a/tests/testthat/test-gridlist.R b/tests/testthat/test-gridlist.R index 72ee0ac8..2a168614 100644 --- a/tests/testthat/test-gridlist.R +++ b/tests/testthat/test-gridlist.R @@ -1,32 +1,31 @@ test_that("gridlist works correctly", { - gl <- gridlist(boeker, feixas2004) expect_s3_class(gl, "gridlist") expect_length(gl, 2) - - gl2 <- rep(boeker, n = 3) + + gl2 <- rep(boeker, n = 3) expect_s3_class(gl2, "gridlist") expect_length(gl2, 3) - + expect_error(rep.repgrid(1, n = 4), "'x' must be a 'repgrid' object") - + expect_error(gridlist(1, 2), "All element of 'x' must be 'repgrid' objects") - + expect_equal(gl, as.gridlist(gl)) expect_error(as.gridlist(c(1, 2)), "'x' must be a list.") - + expect_true(is.gridlist(gl)) expect_false(is.gridlist(list())) expect_false(is.gridlist(1:3)) - + dim_expected <- list(constructs = c(15, 13), elements = c(14, 20)) expect_equal(dim(gl), dim_expected) - - expect_output(print(gl, all=TRUE)) - expect_output(print(gl), regexp=NULL, - "length: 2", "no of constructs [min, max]: [13, 15]", - "no of elements [min, max]: [14, 20]") - expect_error(print.gridlist(list(), "'x'must be a 'gridlist' object")) - + expect_output(print(gl, all = TRUE)) + expect_output(print(gl), + regexp = NULL, + "length: 2", "no of constructs [min, max]: [13, 15]", + "no of elements [min, max]: [14, 20]" + ) + expect_error(print.gridlist(list(), "'x'must be a 'gridlist' object")) }) diff --git a/tests/testthat/test-indexes.R b/tests/testthat/test-indexes.R index 4cab9405..8b870eca 100644 --- a/tests/testthat/test-indexes.R +++ b/tests/testthat/test-indexes.R @@ -4,7 +4,7 @@ test_that("PVAFF returns expected value", { suppressMessages({ - v <- indexPvaff(boeker) + v <- indexPvaff(boeker) }) expect_equal(v, 0.42007) }) @@ -13,20 +13,19 @@ test_that("PVAFF returns expected value", { test_that("indexDilemma matches Gridcor results", { id <- indexDilemma(boeker, self = 1, ideal = 2, r.min = .35) expect_equal(id$no_ids, 4) - - #zero dilemmas do not cause error + + # zero dilemmas do not cause error id <- indexDilemma(boeker, self = 1, ideal = 2, r.min = .99) expect_equal(id$no_ids, 0) }) test_that("indexSelfConstruction works correctly", { - # by default, other element are all except self and ideal x <- indexSelfConstruction(feixas2004, self = 1, ideal = 13) check <- length(x$other_elements) == ncol(feixas2004) - 2 expect_true(check) - + # error is thrown if i is out of range expect_error({ x <- indexSelfConstruction(feixas2004, 1, 14) @@ -39,7 +38,7 @@ test_that("indexSelfConstruction works correctly", { }) # duplicate indexes not allowed expect_error({ - x <- indexSelfConstruction(feixas2004, 1, 13, others = c(3,3,4)) + x <- indexSelfConstruction(feixas2004, 1, 13, others = c(3, 3, 4)) }) # rounding of 'others' element works correctly a <- indexSelfConstruction(feixas2004, self = 1, ideal = 13, round = FALSE) @@ -47,16 +46,14 @@ test_that("indexSelfConstruction works correctly", { expect_true({ all(round(ratings(a$grid)) == ratings(b$grid)) }) - }) test_that("indexDilemmatic works correctly", { - # by default, other element are all except self and ideal x <- indexDilemmatic(feixas2004, ideal = 13) expect_true(x$n_dilemmatic == 1) - + # error is thrown if i is out of range expect_error({ x <- indexDilemmatic(feixas2004, ideal = 14) @@ -64,7 +61,7 @@ test_that("indexDilemmatic works correctly", { expect_error({ x <- indexDilemmatic(feixas2004, ideal = 0) }) - + # warn for even scale length expect_warning({ x <- randomGrid(range = c(1, 6)) @@ -75,14 +72,12 @@ test_that("indexDilemmatic works correctly", { x <- randomGrid(range = c(0, 100)) indexDilemmatic(x, ideal = 1) }) - }) test_that("matches works correctly", { - m <- matches(feixas2004) - + # error is thrown if i is out of range expect_error({ m <- matches(feixas2004, deviation = -1) @@ -95,33 +90,31 @@ test_that("matches works correctly", { print(m, width = -1) }) ) - + ## check results x <- feixas2004 - + # maximal no of matches per C/E correct (infinity case gives max number) m <- matches(x, deviation = Inf, diag.na = FALSE) expect_true(all(m$elements == nrow(x))) expect_true(all(m$constructs == ncol(x))) - - # maximal possible number of matches is correct + + # maximal possible number of matches is correct m <- matches(x, deviation = Inf) expect_true(m$max_constructs == sum(m$constructs, na.rm = T) / 2) expect_true(m$max_elements == sum(m$elements, na.rm = T) / 2) - }) test_that("indexBieri works correctly", { - x <- feixas2004 b <- indexBieri(x) - + # error is thrown if i is out of range expect_error({ b <- matches(x, deviation = -1) }) - + ## check results # maximal no of matches per C correct (infinity case gives max number) b <- indexBieri(x, deviation = Inf) @@ -131,44 +124,42 @@ test_that("indexBieri works correctly", { test_that("indexDDI works correctly", { - - files <- system.file("extdata", c("dep_grid_walker_1988_1.xlsx", "dep_grid_walker_1988_2.xlsx") , package = "OpenRepGrid") - + files <- system.file("extdata", c("dep_grid_walker_1988_1.xlsx", "dep_grid_walker_1988_2.xlsx"), package = "OpenRepGrid") + g_1 <- importExcel(files[1]) g_2 <- importExcel(files[2]) - + # check results against values from paper (Walker et al. (1988), p. 65 ff.) di <- indexDDI(g_1, 2:5) - expected <- c(1.6, 1.8, 2.0, 2.0) # table 1 + expected <- c(1.6, 1.8, 2.0, 2.0) # table 1 expect_equal(round(di, 1), expected) - + di <- indexDDI(g_2, 2:5) - expected <- c(1.9, 2.7, 3.3, 3.9) # table 2 + expected <- c(1.9, 2.7, 3.3, 3.9) # table 2 expect_equal(round(di, 1), expected) - + # negative values for ds are not allowed expect_error({ indexDDI(x, ds = -1) }) - + # only 0/1 ratings are allowed expect_error({ - indexDDI(boeker, ds=2) + indexDDI(boeker, ds = 2) }) }) test_that("indexUncertainty works correctly", { - - file <- system.file("extdata", "dep_grid_bell_2001.xlsx" , package = "OpenRepGrid") + file <- system.file("extdata", "dep_grid_bell_2001.xlsx", package = "OpenRepGrid") g <- importExcel(file) - + # check results against values from paper (Bell, 2001 p.231, Fig.1) ui <- indexUncertainty(g) given <- round(ui, 2) expected <- c("Uncertainty Index" = .99) expect_equal(given, expected) - + # only 0/1 ratings are allowed expect_error({ indexUncertainty(boeker) diff --git a/tests/testthat/test_bertin.R b/tests/testthat/test_bertin.R index 8cf4636f..3817c000 100644 --- a/tests/testthat/test_bertin.R +++ b/tests/testthat/test_bertin.R @@ -2,10 +2,10 @@ library(vdiffr) test_that("bertin works", { expect_doppelganger("bertin", bertin(feixas2004)) - + create_bertinCluster <- function() { set.seed(0) suppressMessages(h <- bertinCluster(feixas2004)) # ward -> ward.D message } expect_doppelganger("bertinCluster", create_bertinCluster) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_biplot.R b/tests/testthat/test_biplot.R index 9035633b..c1c81a36 100644 --- a/tests/testthat/test_biplot.R +++ b/tests/testthat/test_biplot.R @@ -1,22 +1,18 @@ - library(testthat) library(vdiffr) library(vdiffr) test_that("biplots work", { - create_biplot2d <- function() { set.seed(0) biplot2d(boeker) } expect_doppelganger("biplot2d", create_biplot2d) - + create_biplotPseudo3d <- function() { set.seed(0) biplotPseudo3d(boeker) } expect_doppelganger("biplotPseudo3d", create_biplotPseudo3d) - }) -