From 52c5e66f2d1d5b88e03a33efb3ecb8e894109a7c Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Wed, 7 May 2025 09:37:05 +0200 Subject: [PATCH 01/23] README: add SO question hint --- README.Rmd | 8 ++++++++ README.md | 10 ++++++++++ 2 files changed, 18 insertions(+) diff --git a/README.Rmd b/README.Rmd index e0cedb7..24d923d 100644 --- a/README.Rmd +++ b/README.Rmd @@ -67,6 +67,14 @@ And for a first impression of the package features type Visit the package documentation website: +## Questions + +If you get stuck, you can get help on [StackOverflow](https://stackoverflow.com/): + +- Make sure to read [How to write a good R question with a reproducible example](https://stackoverflow.com/collectives/r-language/articles/76995406/how-to-write-a-good-r-question-with-a-reproducible-example) before posting your question +- Add the tags `R` and `openrepgrid` to your question + + ## Contributing to OpenRepGrid You can contribute to OpenRepGrid in various ways. You can, for example, file a bug report, help improve the documentation or write code. See the our [contributing guide](https://docs.openrepgrid.org/CONTRIBUTING.html) for detailed information. diff --git a/README.md b/README.md index 5c694a8..9beffeb 100644 --- a/README.md +++ b/README.md @@ -76,6 +76,16 @@ And for a first impression of the package features type Visit the package documentation website: +## Questions + +If you get stuck, you can get help on +[StackOverflow](https://stackoverflow.com/): + +- Make sure to read [How to write a good R question with a reproducible + example](https://stackoverflow.com/collectives/r-language/articles/76995406/how-to-write-a-good-r-question-with-a-reproducible-example) + before posting your question +- Add the tags `R` and `openrepgrid` to your question + ## Contributing to OpenRepGrid You can contribute to OpenRepGrid in various ways. You can, for example, From 9762f58c26fd9218506d89cee3a71393d0ecc03a Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Thu, 8 May 2025 15:51:01 +0200 Subject: [PATCH 02/23] biplot2d: hide element and construct labels (fix #8) --- R/repgrid-plots.r | 30 +++++++++++++++++------------- man/biplotDraw.Rd | 4 ++-- 2 files changed, 19 insertions(+), 15 deletions(-) diff --git a/R/repgrid-plots.r b/R/repgrid-plots.r index 70420b0..2dd45d0 100644 --- a/R/repgrid-plots.r +++ b/R/repgrid-plots.r @@ -832,8 +832,8 @@ prepareBiplotData <- function(x, dim = c(1, 2), map.dim = 3, biplotDraw <- function(x, inner.positioning = TRUE, outer.positioning = TRUE, - c.labels.inside = F, - flipaxes = c(F, F), + c.labels.inside = FALSE, + 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), @@ -1088,16 +1088,18 @@ biplotDraw <- function(x, # 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 + cli <- subset(x, type %in% c("cl", "cr") & showlabel == TRUE) # select only labels that should be shown + if (nrow(cli) > 0) { + 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) < max.ext & abs(y) < max.ext) + cs <- subset(x, type %in% c("cl", "cr") & showpoint == TRUE & abs(x) < max.ext & abs(y) < max.ext) points(cs[c("x", "y")], col = cs$point.col, pch = 4, cex = cs$point.cex, xpd = xpd) # make element symbols - es <- subset(x, type == "e" & showpoint == T & abs(x) < max.ext & abs(y) < max.ext) + es <- subset(x, type == "e" & showpoint == TRUE & abs(x) < max.ext & abs(y) < max.ext) points(es[c("x", "y")], col = es$point.col, pch = 15, cex = es$point.cex, xpd = xpd) # positioning of element and constructs labels inside the plot @@ -1108,13 +1110,15 @@ biplotDraw <- function(x, 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 + sh <- subset(x, showlabel == TRUE & showpoint == TRUE) + if (nrow(sh) > 0) { + 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 == TRUE & x$showpoint == TRUE, ] <- sh + } } else { # simple offsetting in y direction x$x.pos <- x$x x$y.pos <- NA diff --git a/man/biplotDraw.Rd b/man/biplotDraw.Rd index 756c0e9..cd3be96 100644 --- a/man/biplotDraw.Rd +++ b/man/biplotDraw.Rd @@ -8,8 +8,8 @@ biplotDraw( x, inner.positioning = TRUE, outer.positioning = TRUE, - c.labels.inside = F, - flipaxes = c(F, F), + c.labels.inside = FALSE, + flipaxes = c(FALSE, FALSE), strokes.x = 0.1, strokes.y = 0.1, offsetting = TRUE, From 8691bd5a7574b94dc517ac8d6cfdfe00f8583fd7 Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Thu, 8 May 2025 16:12:01 +0200 Subject: [PATCH 03/23] biplot3d: Construct spheres hidden, axews start at origin (#25) `biplot3d`: New arg `c.sphere.show` and new defaults: Construct spheres now hidden by default, construct axes start at origin now. --- NEWS.md | 5 +++++ R/rgl-3d.r | 16 ++++++++++------ man/biplot3d.Rd | 5 ++++- 3 files changed, 19 insertions(+), 7 deletions(-) diff --git a/NEWS.md b/NEWS.md index db7adfd..74477fc 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,8 @@ +# OpenRepGrid 0.1.18 (dev version) + +* `biplot3d`: New arg `c.sphere.show` and new defaults: Construct spheres now hidden by default, construct axes start + at origin (#25) + # OpenRepGrid 0.1.17 * `clusterBoot` gains `trim` arg. Construct labels in dendrogram are no longer trimmed by default (#58). diff --git a/R/rgl-3d.r b/R/rgl-3d.r index c65ab5b..636762b 100644 --- a/R/rgl-3d.r +++ b/R/rgl-3d.r @@ -149,6 +149,7 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. lef = 1.1, frame = 1, col.frame = grey(.6), col.sphere = "black", alpha.sphere = .05, zoom = 1, draw.xyz.axes = TRUE, + c.sphere.show = FALSE, # c.points.show=TRUE, # c.labels.show=TRUE, # e.points.show=TRUE, @@ -241,7 +242,9 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. } else { stop("'lines.c' can only take numeric values from 0 to 2") } - rglDrawConstructPoints(cs.p.xyz, c.radius = mval / 200, ...) + if (c.sphere.show) { + rglDrawConstructPoints(cs.p.xyz, c.radius = mval / 200, ...) + } # rglDrawConstructPoints(-Cu[, dim], c.radius=mval/200, ...) # rglDrawStandardEllipses(max.dim) @@ -314,13 +317,13 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. #' `2 =` lines from the center to outer frame. #' @param lef Construct lines extension factor #' -#' @param center Numeric. The type of centering to be performed. +#' @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) +#' @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 @@ -334,6 +337,7 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. #' determine the solution. Default is `NA`, i.e. no elements are set #' supplementary. #' +#' @param c.sphere.show Show construct spheres (default is `FALSE`). #' @param c.sphere.col Color of construct spheres. #' @param c.cex Size of construct text. #' @param c.text.col Color for construct text. @@ -396,10 +400,10 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. #' ) #' } #' -biplot3d <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines.c = TRUE, +biplot3d <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines.c = 2, 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), + c.sphere.show = FALSE, 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, @@ -409,7 +413,7 @@ biplot3d <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines.c = T 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, + c.sphere.show = c.sphere.show, 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, ... diff --git a/man/biplot3d.Rd b/man/biplot3d.Rd index aa927c3..757f3ce 100644 --- a/man/biplot3d.Rd +++ b/man/biplot3d.Rd @@ -9,7 +9,7 @@ biplot3d( dim = 1:3, labels.e = TRUE, labels.c = TRUE, - lines.c = TRUE, + lines.c = 2, lef = 1.3, center = 1, normalize = 0, @@ -17,6 +17,7 @@ biplot3d( h = 1, col.active = NA, col.passive = NA, + c.sphere.show = FALSE, c.sphere.col = grey(0.4), c.cex = 0.6, c.text.col = grey(0.4), @@ -71,6 +72,8 @@ in the SVD but projected into the component space afterwards. They do not determine the solution. Default is \code{NA}, i.e. no elements are set supplementary.} +\item{c.sphere.show}{Show construct spheres (default is \code{FALSE}).} + \item{c.sphere.col}{Color of construct spheres.} \item{c.cex}{Size of construct text.} From 5beb5ae9ce48042f1ff8625239c8b3d64a7eab8b Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Thu, 8 May 2025 17:59:11 +0200 Subject: [PATCH 04/23] fix `align` function (#22) fix `align` function which caused a bug in `bertinCluster` --- DESCRIPTION | 4 ++-- NEWS.md | 1 + R/calc.r | 13 ++++++++++--- 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index af26c8d..e2009e9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,8 +16,8 @@ Description: Analyze repertory grids, a qualitative-quantitative to quantitatively analyze and visualize repertory grid data (e.g. 'Fransella', 'Bell', & 'Bannister', 2004, ISBN: 978-0-470-09080-0). The package is part of the The package is part of the project. -Version: 0.1.17 -Date: 2025-03-02 +Version: 0.1.18.9001 +Date: 2025-05-08 Encoding: UTF-8 URL: https://github.com/markheckmann/OpenRepGrid Imports: diff --git a/NEWS.md b/NEWS.md index 74477fc..7dbf9b1 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # OpenRepGrid 0.1.18 (dev version) +* fix `align` function which caused a bug in `bertinCluster` (#22) * `biplot3d`: New arg `c.sphere.show` and new defaults: Construct spheres now hidden by default, construct axes start at origin (#25) diff --git a/R/calc.r b/R/calc.r index 9e3d177..6b40e67 100644 --- a/R/calc.r +++ b/R/calc.r @@ -1204,7 +1204,8 @@ cluster <- function(x, along = 0, dmethod = "euclidean", cmethod = "ward.D", p = # function calculates cluster dendrogram from doublebind grid matrix -# and reverses the constructs accoring to the upper big cluster +# by seleting the frist occurence of the reordered grid after clustering +# we (probably) get a decent alignment. NB: Seriation would probably be better. align <- function(x, along = 0, dmethod = "euclidean", cmethod = "ward.D", p = 2, ...) { x2 <- doubleEntry(x) @@ -1212,8 +1213,14 @@ align <- function(x, along = 0, dmethod = "euclidean", dmethod = dmethod, cmethod = cmethod, p = p, align = FALSE, print = FALSE ) - nc <- getNoOfConstructs(xr) / 2 - xr[1:nc, ] + # step 1: cluster by distance + # step 2: take the first occurence of each constructs (see #22) + # => should yield a reasonable alignment. Unclear if it has edge cases. + df_con <- constructs(xr) + l <- as.list(as.data.frame(t(df_con))) # df rows as list + con <- vapply(l, function(x) paste(sort(x), collapse = " "), character(1)) + ii <- which(!duplicated(con)) + xr[ii, ] } From 30a000712494788fb91930a785e3f6b23643452a Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Thu, 8 May 2025 18:59:29 +0200 Subject: [PATCH 05/23] add tests for fix in align() (#22, #31) --- NEWS.md | 2 +- tests/testthat/test-calc.R | 22 +++++++++ tests/testthat/test_biplot.R | 2 +- tests/testthat/testdata/issue_22.txt | 45 ++++++++++++++++++ tests/testthat/testdata/issue_31.txt | 69 ++++++++++++++++++++++++++++ 5 files changed, 138 insertions(+), 2 deletions(-) create mode 100644 tests/testthat/test-calc.R create mode 100644 tests/testthat/testdata/issue_22.txt create mode 100644 tests/testthat/testdata/issue_31.txt diff --git a/NEWS.md b/NEWS.md index 7dbf9b1..f145425 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,6 @@ # OpenRepGrid 0.1.18 (dev version) -* fix `align` function which caused a bug in `bertinCluster` (#22) +* fix bug in `align` which caused constructs to disappear and subsequent bugs in `bertinCluster` and `cluster` (#22, #31) * `biplot3d`: New arg `c.sphere.show` and new defaults: Construct spheres now hidden by default, construct axes start at origin (#25) diff --git a/tests/testthat/test-calc.R b/tests/testthat/test-calc.R new file mode 100644 index 0000000..b2c2ebc --- /dev/null +++ b/tests/testthat/test-calc.R @@ -0,0 +1,22 @@ + +# test for issues #22 and #31 (constructs were missing after align) +test_that("align()", { + + sorted_poles <- function(x) { + df_con <- constructs(x) + l <- as.list(as.data.frame(t(df_con))) # df rows as list + vapply(l, function(x) paste(sort(x), collapse = " "), character(1)) + } + + file <- testthat::test_path("testdata/issue_22.txt") + x <- importTxt(file) + x_aligned <- align(x) + d <- setdiff(sorted_poles(x), sorted_poles(x_aligned)) + expect_length(d, 0) + + file <- testthat::test_path("testdata/issue_31.txt") + x <- importTxt(file) + x_aligned <- align(x) + d <- setdiff(sorted_poles(x), sorted_poles(x_aligned)) + expect_length(d, 0) +}) diff --git a/tests/testthat/test_biplot.R b/tests/testthat/test_biplot.R index c1c81a3..4da8973 100644 --- a/tests/testthat/test_biplot.R +++ b/tests/testthat/test_biplot.R @@ -1,9 +1,9 @@ library(testthat) library(vdiffr) -library(vdiffr) test_that("biplots work", { + create_biplot2d <- function() { set.seed(0) biplot2d(boeker) diff --git a/tests/testthat/testdata/issue_22.txt b/tests/testthat/testdata/issue_22.txt new file mode 100644 index 0000000..fb445a7 --- /dev/null +++ b/tests/testthat/testdata/issue_22.txt @@ -0,0 +1,45 @@ +========================= +Data File for OpenRepGrid +========================= + +ELEMENTS +e-1 +e-2 +e-3 +e-4 +e-5 +e-6 +e-7 +e-8 +e-9 +END ELEMENTS + +CONSTRUCTS +l-1 : r-1 +l-2 : r-2 +l-3 : r-3 +l-4 : r-4 +l-5 : r-5 +l-6 : r-6 +l-7 : r-7 +l-8 : r-8 +l-9 : r-9 +l-10 : r-10 +END CONSTRUCTS + +RATINGS +3 3 4 4 2 3 5 2 4 +1 1 3 2 1 3 4 3 2 +5 5 5 2 1 1 1 4 4 +3 4 2 4 3 3 2 3 3 +5 5 2 3 2 2 3 3 3 +5 5 5 1 1 2 1 5 5 +4 4 4 5 4 3 1 3 1 +5 5 4 5 1 1 4 1 3 +3 4 3 2 1 2 1 3 5 +4 4 3 5 2 2 4 2 2 +END RATINGS + +RANGE +1 5 +END RANGE diff --git a/tests/testthat/testdata/issue_31.txt b/tests/testthat/testdata/issue_31.txt new file mode 100644 index 0000000..c2c0685 --- /dev/null +++ b/tests/testthat/testdata/issue_31.txt @@ -0,0 +1,69 @@ +========================= +Data File for OpenRepGrid +========================= + +ELEMENTS +e-1 +e-2 +e-3 +e-4 +e-5 +e-6 +e-7 +e-8 +e-9 +END ELEMENTS + +CONSTRUCTS +l-1 : r-1 +l-2 : r-2 +l-3 : r-3 +l-4 : r-4 +l-5 : r-5 +l-6 : r-6 +l-7 : r-7 +l-8 : r-8 +l-9 : r-9 +l-10 : r-10 +l-11 : r-11 +l-12 : r-12 +l-13 : r-13 +l-14 : r-14 +l-15 : r-15 +l-16 : r-16 +l-17 : r-17 +l-18 : r-18 +l-19 : r-19 +l-20 : r-20 +l-21 : r-21 +l-22 : r-22 +END CONSTRUCTS + +RATINGS +2 2 2 2 2 2 2 2 3 +1 4 3 1 3 3 2 2 4 +2 3 3 4 2 2 2 1 1 +2 2 4 2 2 2 2 2 2 +3 2 1 2 6 6 4 4 7 +2 3 4 4 2 1 2 2 1 +2 2 3 3 2 1 2 1 1 +2 2 2 2 2 2 3 2 1 +4 6 2 4 4 5 6 4 6 +2 3 3 5 2 2 3 2 2 +2 3 1 1 3 2 2 2 2 +3 3 3 1 4 5 4 4 4 +2 2 3 2 3 3 1 3 2 +2 1 4 4 4 2 2 1 2 +3 3 3 3 3 1 1 2 3 +2 2 3 2 5 5 2 5 6 +3 1 2 1 3 3 2 3 2 +2 2 2 2 2 2 1 1 2 +4 2 2 3 6 3 1 5 4 +2 2 2 1 2 2 2 1 2 +1 1 4 2 2 2 2 3 2 +3 2 3 2 3 3 3 3 2 +END RATINGS + +RANGE +1 7 +END RANGE From 14fb32614ef34839a2347e2cec45e29c2e58ab1f Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Thu, 8 May 2025 19:15:02 +0200 Subject: [PATCH 06/23] `distanceHartmann`: `method` arg default now `simulate` (#19) --- DESCRIPTION | 2 +- NEWS.md | 1 + R/distance.R | 4 ++-- man/distanceHartmann.Rd | 4 ++-- 4 files changed, 6 insertions(+), 5 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e2009e9..24daaa6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,7 +16,7 @@ Description: Analyze repertory grids, a qualitative-quantitative to quantitatively analyze and visualize repertory grid data (e.g. 'Fransella', 'Bell', & 'Bannister', 2004, ISBN: 978-0-470-09080-0). The package is part of the The package is part of the project. -Version: 0.1.18.9001 +Version: 0.1.18.9002 Date: 2025-05-08 Encoding: UTF-8 URL: https://github.com/markheckmann/OpenRepGrid diff --git a/NEWS.md b/NEWS.md index f145425..8fc5f85 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # OpenRepGrid 0.1.18 (dev version) +* `distanceHartmann`: change default for `method` arg to `simulate` (#19) * fix bug in `align` which caused constructs to disappear and subsequent bugs in `bertinCluster` and `cluster` (#22, #31) * `biplot3d`: New arg `c.sphere.show` and new defaults: Construct spheres now hidden by default, construct axes start at origin (#25) diff --git a/R/distance.R b/R/distance.R index 55c9dab..2860170 100644 --- a/R/distance.R +++ b/R/distance.R @@ -449,7 +449,7 @@ getDistributionParameters <- function(x, probs = c(.01, .025, .05, .1, .9, .95, #' 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 +#' simulation may 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 #' Slater distances (default is `10000`). Note that @@ -501,7 +501,7 @@ getDistributionParameters <- function(x, probs = c(.01, .025, .05, .1, .9, .95, #' hist(l$hartmann, breaks = 100) #' } #' -distanceHartmann <- function(x, method = "paper", reps = 10000, +distanceHartmann <- function(x, method = "simulate", reps = 10000, prob = NULL, progress = TRUE, distributions = FALSE) { if (distributions == TRUE & method != "simulate") { method <- "simulate" diff --git a/man/distanceHartmann.Rd b/man/distanceHartmann.Rd index 527c8a3..40ff949 100644 --- a/man/distanceHartmann.Rd +++ b/man/distanceHartmann.Rd @@ -6,7 +6,7 @@ \usage{ distanceHartmann( x, - method = "paper", + method = "simulate", reps = 10000, prob = NULL, progress = TRUE, @@ -21,7 +21,7 @@ distanceHartmann( parameters as given in Hartmann (1992) for calculation. \code{"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 +simulation may be replaced by more accurate parameters for Hartmann distances than used in Hartmann (1992).} \item{reps}{Number of random grids to generate sample distribution for From 19c33d2f94b7909065fd7cf9bd38273c5838ce5c Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Thu, 8 May 2025 19:26:17 +0200 Subject: [PATCH 07/23] print.distance(): fix docs for `cutoffs` arg (#18) --- DESCRIPTION | 2 +- NEWS.md | 1 + R/distance.R | 5 ++--- man/print.distance.Rd | 5 ++--- man/print.hdistance.Rd | 5 ++--- 5 files changed, 8 insertions(+), 10 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 24daaa6..b363e28 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,7 +16,7 @@ Description: Analyze repertory grids, a qualitative-quantitative to quantitatively analyze and visualize repertory grid data (e.g. 'Fransella', 'Bell', & 'Bannister', 2004, ISBN: 978-0-470-09080-0). The package is part of the The package is part of the project. -Version: 0.1.18.9002 +Version: 0.1.18.9003 Date: 2025-05-08 Encoding: UTF-8 URL: https://github.com/markheckmann/OpenRepGrid diff --git a/NEWS.md b/NEWS.md index 8fc5f85..a681f78 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # OpenRepGrid 0.1.18 (dev version) +* `print.distance`: fix docs for `cutoffs` arg (#18) * `distanceHartmann`: change default for `method` arg to `simulate` (#19) * fix bug in `align` which caused constructs to disappear and subsequent bugs in `bertinCluster` and `cluster` (#22, #31) * `biplot3d`: New arg `c.sphere.show` and new defaults: Construct spheres now hidden by default, construct axes start diff --git a/R/distance.R b/R/distance.R index 2860170..d5c74d3 100644 --- a/R/distance.R +++ b/R/distance.R @@ -125,9 +125,8 @@ dist_minmax <- function(x, along = 1, dmethod = "euclidean", p = 2, max.only = F #' the output (default is `TRUE`). #' @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 -#' values. +#' @param cutoffs Cutoff values. Only values outside the interval are printed. +#' For Slater distances `c(.8, 1.2)` are common values. #' @param diag Whether to show the matrix diagonal. #' @param ... Not evaluated. #' @export diff --git a/man/print.distance.Rd b/man/print.distance.Rd index de307f7..9fa370d 100644 --- a/man/print.distance.Rd +++ b/man/print.distance.Rd @@ -30,9 +30,8 @@ the output (default is \code{TRUE}).} \item{diag}{Whether to show the matrix diagonal.} -\item{cutoffs}{Cutoff values. Values below or above this interval are not -printed. For Slater distances \code{c(.8, 1.2)} are common -values.} +\item{cutoffs}{Cutoff values. Only values outside the interval are printed. +For Slater distances \code{c(.8, 1.2)} are common values.} \item{...}{Not evaluated.} } diff --git a/man/print.hdistance.Rd b/man/print.hdistance.Rd index 2417d6e..055e03f 100644 --- a/man/print.hdistance.Rd +++ b/man/print.hdistance.Rd @@ -31,9 +31,8 @@ the output (default is \code{TRUE}).} \item{diag}{Whether to show the matrix diagonal.} -\item{cutoffs}{Cutoff values. Values below or above this interval are not -printed. For Slater distances \code{c(.8, 1.2)} are common -values.} +\item{cutoffs}{Cutoff values. Only values outside the interval are printed. +For Slater distances \code{c(.8, 1.2)} are common values.} \item{p}{Quantiles corresponding to probabilities are used as cutoffs. Currently only works for Hartmann distances. If used \code{cutoffs} is overwritten.} From c62399b4af058a32d866566a1a313224884b727a Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Thu, 8 May 2025 19:59:31 +0200 Subject: [PATCH 08/23] biplot3d: add args `e.sphere.show`, `e.labels.show` (#9) --- DESCRIPTION | 2 +- R/rgl-3d.r | 15 +++++++++++++-- man/biplot3d.Rd | 12 ++++++++++++ 3 files changed, 26 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b363e28..01e28ad 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,7 +16,7 @@ Description: Analyze repertory grids, a qualitative-quantitative to quantitatively analyze and visualize repertory grid data (e.g. 'Fransella', 'Bell', & 'Bannister', 2004, ISBN: 978-0-470-09080-0). The package is part of the The package is part of the project. -Version: 0.1.18.9003 +Version: 0.1.18.9004 Date: 2025-05-08 Encoding: UTF-8 URL: https://github.com/markheckmann/OpenRepGrid diff --git a/R/rgl-3d.r b/R/rgl-3d.r index 636762b..593ff64 100644 --- a/R/rgl-3d.r +++ b/R/rgl-3d.r @@ -224,7 +224,7 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. 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) + if (draw.xyz.axes) rglDrawStandardAxes(mval, spheres = FALSE) # rglDrawConstructLabels(Cu[, dim], labels=labels.r, ...) # rglDrawConstructLabels(-Cu[, dim], labels=labels.l, ...) } else if (lines.c == 1) { # construct lines from cons pos to outside @@ -341,7 +341,14 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. #' @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.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 +#' 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 +#' provided (e.g. `c(1:10)`). #' @param e.sphere.col Color of elements. #' @param e.cex Size of element labels. #' @param e.text.col Color of element labels. @@ -403,7 +410,9 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. biplot3d <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines.c = 2, lef = 1.3, center = 1, normalize = 0, g = 0, h = 1, col.active = NA, col.passive = NA, + #c.points.show = TRUE, c.labels.show = TRUE, c.sphere.show = FALSE, c.sphere.col = grey(.4), c.cex = .6, c.text.col = grey(.4), + e.sphere.show = TRUE, e.labels.show = TRUE, e.sphere.col = grey(0), e.cex = .6, e.text.col = grey(0), alpha.sphere = .05, col.sphere = "black", unity = FALSE, @@ -413,7 +422,9 @@ biplot3d <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines.c = 2 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.points.show = c.points.show, c.labels.show = c.labels.show, c.sphere.show = c.sphere.show, c.sphere.col = c.sphere.col, c.cex = c.cex, c.text.col = c.text.col, + e.points.show = e.sphere.show, e.labels.show = e.labels.show, 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, ... diff --git a/man/biplot3d.Rd b/man/biplot3d.Rd index 757f3ce..54e1010 100644 --- a/man/biplot3d.Rd +++ b/man/biplot3d.Rd @@ -21,6 +21,8 @@ biplot3d( c.sphere.col = grey(0.4), c.cex = 0.6, c.text.col = grey(0.4), + e.sphere.show = TRUE, + e.labels.show = TRUE, e.sphere.col = grey(0), e.cex = 0.6, e.text.col = grey(0), @@ -80,6 +82,16 @@ supplementary.} \item{c.text.col}{Color for construct text.} +\item{e.sphere.show}{Whether the elements are printed (default is \code{TRUE}). +\code{FALSE} will suppress the printing of the elements. +To only print certain elements a numeric vector can be +provided (e.g. \code{c(1:10)}).} + +\item{e.labels.show}{Whether the element labels are printed (default is \code{TRUE}). +\code{FALSE} will suppress the printing of the labels. +To only print certain element labels a numeric vector can be +provided (e.g. \code{c(1:10)}).} + \item{e.sphere.col}{Color of elements.} \item{e.cex}{Size of element labels.} From a3091350d290561c6ad6724c63ada3fe66c6d70c Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Thu, 8 May 2025 20:48:23 +0200 Subject: [PATCH 09/23] biplot3d: new args c.axis.show, c.sphere.show (#9) --- DESCRIPTION | 2 +- R/rgl-3d.r | 77 ++++++++++---------------------- inst/examples/example-biplot3d.R | 13 ++++++ man/biplot3d.Rd | 30 ++++++------- 4 files changed, 51 insertions(+), 71 deletions(-) create mode 100644 inst/examples/example-biplot3d.R diff --git a/DESCRIPTION b/DESCRIPTION index 01e28ad..acc37e3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,7 +16,7 @@ Description: Analyze repertory grids, a qualitative-quantitative to quantitatively analyze and visualize repertory grid data (e.g. 'Fransella', 'Bell', & 'Bannister', 2004, ISBN: 978-0-470-09080-0). The package is part of the The package is part of the project. -Version: 0.1.18.9004 +Version: 0.1.18.9005 Date: 2025-05-08 Encoding: UTF-8 URL: https://github.com/markheckmann/OpenRepGrid diff --git a/R/rgl-3d.r b/R/rgl-3d.r index 593ff64..8d2a853 100644 --- a/R/rgl-3d.r +++ b/R/rgl-3d.r @@ -148,13 +148,8 @@ rglDrawConstructLabels <- function(coords, labels = FALSE, dim = 1:3, 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.sphere.show = FALSE, - # c.points.show=TRUE, - # c.labels.show=TRUE, - # e.points.show=TRUE, - # e.labels.show=TRUE, - ...) { + draw.xyz.axes = TRUE, ...) { + if (!requireNamespace("rgl", quietly = TRUE)) { stop("The 'rgl' package is required to use OpenRepGrid's 3D features => please install 'rgl'.", call. = FALSE) } @@ -242,9 +237,7 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. } else { stop("'lines.c' can only take numeric values from 0 to 2") } - if (c.sphere.show) { - rglDrawConstructPoints(cs.p.xyz, c.radius = mval / 200, ...) - } + rglDrawConstructPoints(cs.p.xyz, c.radius = mval / 200, ...) # rglDrawConstructPoints(-Cu[, dim], c.radius=mval/200, ...) # rglDrawStandardEllipses(max.dim) @@ -316,13 +309,11 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. #' `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`). @@ -336,26 +327,25 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. #' 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.show Show construct spheres (default is `FALSE`). +#' @param c.axis.show Whether the construct axes are shown (default is `TRUE`). +#' `FALSE` will suppress the printing all axes. +#' To only print certain axes, a numeric vector can be provided (e.g. `c(1:10)`). +#' @param c.sphere.show Whether the construct speheres are shown (default is `FALSE`). +#' To only print certain speheres, a numeric vector can be provided (e.g. `c(1:10)`). #' @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.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 -#' provided (e.g. `c(1:10)`). +#' 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 -#' provided (e.g. `c(1:10)`). +#' To only print certain element labels, a numeric vector can be provided (e.g. `c(1:10)`). #' @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. @@ -365,6 +355,7 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. #' @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: @@ -382,48 +373,26 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. #' 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) +#' @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. #' -#' 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 -#' ) -#' } +#' @example inst/examples/example-biplot3d.R #' biplot3d <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines.c = 2, - lef = 1.3, center = 1, normalize = 0, g = 0, h = 1, col.active = NA, - col.passive = NA, - #c.points.show = TRUE, c.labels.show = TRUE, - c.sphere.show = FALSE, c.sphere.col = grey(.4), c.cex = .6, c.text.col = grey(.4), - e.sphere.show = TRUE, e.labels.show = TRUE, - e.sphere.col = grey(0), e.cex = .6, e.text.col = grey(0), + lef = 1.3, center = 1, normalize = 0, g = 0, h = 1, col.active = NA, col.passive = NA, + c.axis.show = TRUE, c.sphere.show = FALSE, c.sphere.col = grey(.4), c.cex = .6, c.text.col = grey(.4), + e.sphere.show = TRUE, e.labels.show = TRUE, 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, ...) { + 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.points.show = c.points.show, c.labels.show = c.labels.show, - c.sphere.show = c.sphere.show, c.sphere.col = c.sphere.col, c.cex = c.cex, c.text.col = c.text.col, + c.points.show = c.sphere.show, c.labels.show = c.axis.show, + c.sphere.col = c.sphere.col, c.cex = c.cex, c.text.col = c.text.col, e.points.show = e.sphere.show, e.labels.show = e.labels.show, e.sphere.col = e.sphere.col, e.cex = e.cex, e.text.col = e.text.col, alpha.sphere = alpha.sphere, col.sphere = col.sphere, diff --git a/inst/examples/example-biplot3d.R b/inst/examples/example-biplot3d.R new file mode 100644 index 0000000..6b3f01e --- /dev/null +++ b/inst/examples/example-biplot3d.R @@ -0,0 +1,13 @@ +\dontrun{ +biplot3d(boeker) + +biplot3d(boeker, e.sphere.show = 1:4) +biplot3d(boeker, c.axis.show = 1:2) + +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, center = 4) # ESA biplot +} diff --git a/man/biplot3d.Rd b/man/biplot3d.Rd index 54e1010..8839b54 100644 --- a/man/biplot3d.Rd +++ b/man/biplot3d.Rd @@ -17,6 +17,7 @@ biplot3d( h = 1, col.active = NA, col.passive = NA, + c.axis.show = TRUE, c.sphere.show = FALSE, c.sphere.col = grey(0.4), c.cex = 0.6, @@ -74,7 +75,12 @@ in the SVD but projected into the component space afterwards. They do not determine the solution. Default is \code{NA}, i.e. no elements are set supplementary.} -\item{c.sphere.show}{Show construct spheres (default is \code{FALSE}).} +\item{c.axis.show}{Whether the construct axes are shown (default is \code{TRUE}). +\code{FALSE} will suppress the printing all axes. +To only print certain axes, a numeric vector can be provided (e.g. \code{c(1:10)}).} + +\item{c.sphere.show}{Whether the construct speheres are shown (default is \code{FALSE}). +To only print certain speheres, a numeric vector can be provided (e.g. \code{c(1:10)}).} \item{c.sphere.col}{Color of construct spheres.} @@ -84,13 +90,11 @@ supplementary.} \item{e.sphere.show}{Whether the elements are printed (default is \code{TRUE}). \code{FALSE} will suppress the printing of the elements. -To only print certain elements a numeric vector can be -provided (e.g. \code{c(1:10)}).} +To only print certain elements, a numeric vector can be provided (e.g. \code{c(1:10)}).} \item{e.labels.show}{Whether the element labels are printed (default is \code{TRUE}). \code{FALSE} will suppress the printing of the labels. -To only print certain element labels a numeric vector can be -provided (e.g. \code{c(1:10)}).} +To only print certain element labels, a numeric vector can be provided (e.g. \code{c(1:10)}).} \item{e.sphere.col}{Color of elements.} @@ -128,24 +132,18 @@ of elements under investigation (e.g. Raeithel, 1998). } \examples{ \dontrun{ - biplot3d(boeker) -biplot3d(boeker, unity3d = T) -biplot3d(boeker, - e.sphere.col = "red", - c.text.col = "blue" -) +biplot3d(boeker, e.sphere.show = 1:4) +biplot3d(boeker, c.axis.show = 1:2) + +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, center = 4) # ESA biplot } - } \references{ Raeithel, A. (1998). Kooperative Modellproduktion von From 54e053b01a7487d6f0d931e05a1cd1aad8c9cabb Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Thu, 8 May 2025 20:51:02 +0200 Subject: [PATCH 10/23] biplot3d: arg `e.labels.show` --- inst/examples/example-biplot3d.R | 1 + 1 file changed, 1 insertion(+) diff --git a/inst/examples/example-biplot3d.R b/inst/examples/example-biplot3d.R index 6b3f01e..1254be6 100644 --- a/inst/examples/example-biplot3d.R +++ b/inst/examples/example-biplot3d.R @@ -2,6 +2,7 @@ biplot3d(boeker) biplot3d(boeker, e.sphere.show = 1:4) +biplot3d(boeker, e.sphere.show = 1:4, e.labels.show = 1:2) biplot3d(boeker, c.axis.show = 1:2) biplot3d(boeker, e.sphere.col = "red", c.text.col = "blue") From 3ca337d96a804af1173bdbf691826e66c2aaf53e Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Thu, 8 May 2025 20:56:16 +0200 Subject: [PATCH 11/23] biplot3d: add to NEWS.md, tweak example --- NEWS.md | 4 ++-- man/biplot3d.Rd | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index a681f78..2c86e63 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,10 +1,10 @@ # OpenRepGrid 0.1.18 (dev version) +* `biplot3d`: New args `e.sphere.show`, `e.labels.show`, `c.axis.show`. `c.sphere.show`. Construct spheres now hidden + by default. Construct axes start at origin (#9, #25) * `print.distance`: fix docs for `cutoffs` arg (#18) * `distanceHartmann`: change default for `method` arg to `simulate` (#19) * fix bug in `align` which caused constructs to disappear and subsequent bugs in `bertinCluster` and `cluster` (#22, #31) -* `biplot3d`: New arg `c.sphere.show` and new defaults: Construct spheres now hidden by default, construct axes start - at origin (#25) # OpenRepGrid 0.1.17 diff --git a/man/biplot3d.Rd b/man/biplot3d.Rd index 8839b54..e1e9aed 100644 --- a/man/biplot3d.Rd +++ b/man/biplot3d.Rd @@ -135,6 +135,7 @@ of elements under investigation (e.g. Raeithel, 1998). biplot3d(boeker) biplot3d(boeker, e.sphere.show = 1:4) +biplot3d(boeker, e.sphere.show = 1:4, e.labels.show = 1:2) biplot3d(boeker, c.axis.show = 1:2) biplot3d(boeker, e.sphere.col = "red", c.text.col = "blue") From c545e31bc953b4eda9ed0b48f26fc408f818fd0b Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Sun, 11 May 2025 10:27:39 +0200 Subject: [PATCH 12/23] features for preferred poles (#57) - `preferredPoles` sets the preferred construct poles - `preferredPolesByIdeal` sets the preferred pole bases on the ideal elements ratings - `alignByPreferredPole` aligns constructs by pole preference --- DESCRIPTION | 1 + NAMESPACE | 5 +- NEWS.md | 2 + R/openrepgrid.r | 1 + R/preferred_poles.R | 108 +++++++++++++++++++++++++++ R/repgrid-basicops.r | 72 +++++++++++++----- R/repgrid-output.r | 32 +++++--- R/utils.r | 11 +++ dev/57_valence/57_valence.R | 9 +++ man/alignByPreferredPole.Rd | 28 +++++++ man/preferredPolesByIdeal.Rd | 22 ++++++ man/stop_if_not_in_element_range.Rd | 17 +++++ tests/testthat/test-helpers.R | 16 ++++ tests/testthat/test-preferred-pole.R | 20 +++++ 14 files changed, 315 insertions(+), 29 deletions(-) create mode 100644 R/preferred_poles.R create mode 100644 dev/57_valence/57_valence.R create mode 100644 man/alignByPreferredPole.Rd create mode 100644 man/preferredPolesByIdeal.Rd create mode 100644 man/stop_if_not_in_element_range.Rd create mode 100644 tests/testthat/test-helpers.R create mode 100644 tests/testthat/test-preferred-pole.R diff --git a/DESCRIPTION b/DESCRIPTION index acc37e3..5ae7799 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -56,6 +56,7 @@ Collate: 'onair.r' 'openrepgrid.r' 'perturbate.R' + 'preferred_poles.R' 'repgrid.r' 'repgrid-basicops.r' 'repgrid-constructs.r' diff --git a/NAMESPACE b/NAMESPACE index 94fa0f8..6f80071 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -44,6 +44,7 @@ export(addIndexColumnToMatrix) export(addVarianceExplainedToBiplot2d) export(alignByIdeal) export(alignByLoadings) +export(alignByPreferredPole) export(apply_pb) export(as.gridlist) export(bertin) @@ -150,6 +151,7 @@ export(orderByString) export(permuteConstructs) export(permuteGrid) export(perturbate) +export(preferredPolesByIdeal) export(prepareBiplotData) export(print_square_matrix) export(quasiDistributionDistanceSlater) @@ -182,7 +184,6 @@ export(settings) export(settingsLoad) export(settingsSave) export(shift) -export(showMeta) export(showScale) export(slaterStandardization) export(ssq) @@ -190,6 +191,7 @@ export(statsConstructs) export(statsElements) export(stepChart) export(stop_if_not_0_1_ratings_only) +export(stop_if_not_in_element_range) export(stop_if_not_is_repgrid) export(stop_if_scale_not_defined) export(strReverse) @@ -227,3 +229,4 @@ importFrom(crayon,red) importFrom(crayon,silver) importFrom(crayon,white) importFrom(crayon,yellow) +importFrom(dplyr,case_when) diff --git a/NEWS.md b/NEWS.md index 2c86e63..4e02330 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # OpenRepGrid 0.1.18 (dev version) +* `preferredPoles` sets the preferred construct poles, `preferredPolesByIdeal` sets the preferred pole bases on the + ideal elements ratings, `alignByPreferredPole` aligns constructs by pole preference (#57) * `biplot3d`: New args `e.sphere.show`, `e.labels.show`, `c.axis.show`. `c.sphere.show`. Construct spheres now hidden by default. Construct axes start at origin (#9, #25) * `print.distance`: fix docs for `cutoffs` arg (#18) diff --git a/R/openrepgrid.r b/R/openrepgrid.r index f420525..e07d5ea 100644 --- a/R/openrepgrid.r +++ b/R/openrepgrid.r @@ -38,6 +38,7 @@ #' @rawNamespace import(stats, except=c(lag,filter)) #' @rawNamespace import(plyr, except = c(failwith,id,count,mutate,desc,rename,summarize,summarise,filter,arrange)) #' @importFrom colorspace HSV diverge_hcl hex hex2RGB +#' @importFrom dplyr case_when #' @importFrom crayon bold black red green yellow blue magenta cyan white silver #' "_PACKAGE" diff --git a/R/preferred_poles.R b/R/preferred_poles.R new file mode 100644 index 0000000..a983b11 --- /dev/null +++ b/R/preferred_poles.R @@ -0,0 +1,108 @@ + +preferredPoles <- function(x) { + stop_if_not_is_repgrid(x) + left_is_preferred <- sapply(x@constructs, function(c) c$leftpole$preferred) + right_is_preferred <- sapply(x@constructs, function(c) c$rightpole$preferred) + case_when( + left_is_preferred & !right_is_preferred ~ "left", + !left_is_preferred & right_is_preferred ~ "right", + left_is_preferred & right_is_preferred ~ "both", + !left_is_preferred & !right_is_preferred ~ "none", + .default = NA_character_ + ) +} + + +`preferredPoles<-` <- function(x, value) { + stop_if_not_is_repgrid(x) + nc <- nrow(x) + value <- rep_len(value, length.out = nc) + value <- as.character(value) # all NA case + value <- match.arg(value, c("left", "right", "none", "both", NA_character_), several.ok = TRUE) + left_preferred <- value %in% c("left", "both") + right_preferred <- value %in% c("right", "both") + is.na(left_preferred) <- is.na(value) + is.na(right_preferred) <- is.na(value) + ii <- seq_len(nc) + for (i in ii) { + x@constructs[[i]]$leftpole$preferred <- left_preferred[i] + x@constructs[[i]]$rightpole$preferred <- right_preferred[i] + } + x +} + + +#' Set preferred pole by ideal element +#' +#' The preferred construct pole is inferred from the rating of the ideal element. +#' The preferred pole is the side of the ideal element. If the ideal is rated on the +#' scale midpoint (or within `none_range`), none of the poles is preferred. +#' +#' @param x A `repgrid` object. +#' @param ideal Index or name of ideal element. +#' @param none_range Range of ratings that do not allow assining a preferred pole (`NULL` be default). +#' @param align Align preferred poles on same side (default `FALSE`). See [alignByPreferredPoles()]. +#' @export +preferredPolesByIdeal <- function(x, ideal, none_range = NULL, align = FALSE) { + stop_if_not_is_repgrid(x) + stop_if_not_in_element_range(x, ideal) + + midpoint <- getScaleMidpoint(x) + sc <- getScale(x) + if (is.null(none_range)) { + none_range <- midpoint + } else { + stop_if_not_integerish(none_range, arg = "none_range") + } + + idealRatings <- ratings(x)[, ideal] + preferred_pole <- case_when( + idealRatings %in% none_range ~ "none", + idealRatings == midpoint ~ "none", + idealRatings > midpoint ~ "right", + idealRatings < midpoint ~ "left", + .default = NA_character_ + ) + preferredPoles(x) <- preferred_pole + + if (align) { + x <- alignByPreferredPoles(x) + } + x +} + + +#' Align constructs by preferred pole +#' +#' The direction of the constructs in a grid is arbitrary. While their reversal (see [reverse()]) does not affect the information +#' contained in the grid, it is often useful to align constructs for easier interpretation. One way of alignment +#' is placing all positive poles on the same side. Note that this this is only possible if the preferred poles +#' are defined (see [preferredPoles()]). +#' +#' @param x A `repgrid` object. +#' @param side_positive Align all positoive poles on ' +#' @return A `repgrid` object with aligned constructs. +#' @export +#' @seealso [alignByLoadings()] +#' @examples +#' #TBD +alignByPreferredPole <- function(x, side = "right") { + stop_if_not_is_repgrid(x) + side <- match.arg(side, c("left", "right")) + preferred_poles <- preferredPoles(x) + ii_na <- is.na(preferred_poles) + if (any(ii_na)) { + warning(c("Some construct do not have a preferred pole and were not aligned.\n", + "See 'preferredPoles() to set a preference'"), call. = FALSE) + } + if (side == "left") { + ii_reverse <- preferred_poles == "right" + } else { + ii_reverse <- preferred_poles == "left" + } + ii_reverse <- which(ii_reverse) + if (length(ii_reverse) > 0) { + x <- reverse(x, ii_reverse) + } + x +} diff --git a/R/repgrid-basicops.r b/R/repgrid-basicops.r index 82a39ff..fdae763 100644 --- a/R/repgrid-basicops.r +++ b/R/repgrid-basicops.r @@ -48,7 +48,7 @@ stop_if_not_0_1_ratings_only <- function(x, name = "x") { #' @keywords internal #' stop_if_scale_not_defined <- function(x) { - stop_if_not_is_repgrid(x, name) + stop_if_not_is_repgrid(x) 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().") @@ -59,6 +59,43 @@ stop_if_scale_not_defined <- function(x) { } +#' Raise error if element index is outside of range or element name is unknown +#' @param x A `repgrid``` object. +#' @param element Element index or name. +#' @export +#' @keywords internal +stop_if_not_in_element_range <- function(x, element) { + stop_if_not_is_repgrid(x) + if (!is.character(element) && !is.numeric(element)) { + stop("arg 'element' must be the element index (integer) or name (character)", call. = FALSE) + } + .elements <- elements(x) + if (is.character(element) && !element %in% .elements) { + stop("element name '", element, " 'is not unknown", call. = FALSE) + } + if (is.numeric(element) && !is_integerish(element)) { + stop("element index must be an integer", call. = FALSE) + } + ii <- seq_along(.elements) + if (is.numeric(element) && !element %in% ii) { + interval <- paste(range(ii), collapse = ",") + stop("element index ", element, " is outside interval [", interval, "]", call. = FALSE) + } +} + + +stop_if_not_integerish <- function(x, arg = NULL) { + if (!is_integerish(x)) { + if (!is.null(arg)) { + argname <- paste0("for '", arg, "' ") + } else { + argname <- "" + } + stop("Expected integerish value ", argname, "but got '", class(x)[1], "'", call. = FALSE) + } +} + + ############################# EXTRACT AND SET ################################# ## S4 methods @@ -682,7 +719,7 @@ swapPoles <- function(x, pos) { if (missing(pos)) { pos <- seq_along(x@constructs) } - if (any(pos <= 0 | pos > getNoOfConstructs(x))) { + if (any(pos <= 0 | pos > nrow(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)) { @@ -723,11 +760,12 @@ reverse <- function(x, pos = 1L:nrow(x)) { stop("all 'pos' must lie in the interval [1, ", nc, "]", call. = FALSE) } - # swap names of poles - lp <- leftpoles(x)[pos] - rp <- rightpoles(x)[pos] - leftpoles(x)[pos] <- rp - rightpoles(x)[pos] <- lp + # swap 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 sc <- getScale(x) @@ -1344,31 +1382,27 @@ setCoupled <- function(x, coupled = TRUE) { #' #' @param x repgrid object #' @return `NULL` -#' @export -#' @keywords internal -#' @examples \dontrun{ -#' -#' #### TODO #### -#' } +#' @noRd +#' @examples +#' showMeta(boeker) #' 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)) { 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") + cat("Number of constructs: ", length(x@constructs), "\n") + pp <- preferredPoles(x) + cat("Preferred poles defined: ", paste0(sum(!is.na(pp)), "/", length(pp)), "\n") } -# showMeta(x) - - #' Make a new repgrid object. #' diff --git a/R/repgrid-output.r b/R/repgrid-output.r index 83729e4..3fe0c2f 100644 --- a/R/repgrid-output.r +++ b/R/repgrid-output.r @@ -204,13 +204,14 @@ df_out <- function(df, # data frame 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 + keeprows = TRUE, # 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 + hatform = FALSE, # column names in hat form + grid) # repgrid object { # sanity checks if (length(trim) == 1) { # if only one parameter given, extend to the other @@ -440,13 +441,24 @@ df_out <- function(df, # data frame } # 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") + preferred <- preferredPoles(grid) + colors_pole_left <- case_when( + preferred == "left" ~ "green", + preferred == "both" ~ "green", + preferred == "none" ~ "white", + preferred == "right" ~ "red", + is.na(NA) ~ "white" + ) + colors_pole_right <- case_when( + preferred == "right" ~ "green", + preferred == "both" ~ "green", + preferred == "none" ~ "white", + preferred == "left" ~ "red", + is.na(NA) ~ "white" + ) + mat.left.atomic <- colorize_matrix_rows(mat.left.atomic, colors_pole_left) + mat.right.atomic <- colorize_matrix_rows(mat.right.atomic, colors_pole_right) - # 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( @@ -557,7 +569,8 @@ setMethod("show", "repgrid", function(object) { right <- con[, 2] df_out(df.ratings, left, right, just.main = "r", hatform = hatform, id = id, - trim = trim, cut = cut, equal = F, showopt = showopt + trim = trim, cut = cut, equal = FALSE, showopt = showopt, + grid = x ) cat("\n") if (do.bertin) { @@ -565,6 +578,7 @@ setMethod("show", "repgrid", function(object) { } }) + # # Show method for repgrid # # @param repgrid object # setMethod("show", signature= "repgrid", function(object){ diff --git a/R/utils.r b/R/utils.r index 832946c..d80372f 100644 --- a/R/utils.r +++ b/R/utils.r @@ -834,6 +834,17 @@ angle <- function(x, y) { } +# is_integerish(1) +# is_integerish(1.0) +# is_integerish(c(1.0, 2.0)) +is_integerish <- function(x) { + ii <- all(is.numeric(x) | is.integer(x)) + jj <- all(x == as.integer(x)) + ii && jj +} + + + # ////////////////////////////////////////////////////////////////////////////// ### FORMATTING #### # ////////////////////////////////////////////////////////////////////////////// diff --git a/dev/57_valence/57_valence.R b/dev/57_valence/57_valence.R new file mode 100644 index 0000000..5e18e66 --- /dev/null +++ b/dev/57_valence/57_valence.R @@ -0,0 +1,9 @@ +# feat: add construct pole valence (positive/negative/neutral) to repgrid object #57 + +devtools::load_all() + +x <- boeker + +# how to disntinguish between no preferred poles available +# and no preference? + diff --git a/man/alignByPreferredPole.Rd b/man/alignByPreferredPole.Rd new file mode 100644 index 0000000..ac7cee6 --- /dev/null +++ b/man/alignByPreferredPole.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/preferred_poles.R +\name{alignByPreferredPole} +\alias{alignByPreferredPole} +\title{Align constructs by preferred pole} +\usage{ +alignByPreferredPole(x, side = "right") +} +\arguments{ +\item{x}{A \code{repgrid} object.} + +\item{side_positive}{Align all positoive poles on '} +} +\value{ +A \code{repgrid} object with aligned constructs. +} +\description{ +The direction of the constructs in a grid is arbitrary. While their reversal (see \code{\link[=reverse]{reverse()}}) does not affect the information +contained in the grid, it is often useful to align constructs for easier interpretation. One way of alignment +is placing all positive poles on the same side. Note that this this is only possible if the preferred poles +are defined (see \code{\link[=preferredPoles]{preferredPoles()}}). +} +\examples{ +#TBD +} +\seealso{ +\code{\link[=alignByLoadings]{alignByLoadings()}} +} diff --git a/man/preferredPolesByIdeal.Rd b/man/preferredPolesByIdeal.Rd new file mode 100644 index 0000000..f9ac872 --- /dev/null +++ b/man/preferredPolesByIdeal.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/preferred_poles.R +\name{preferredPolesByIdeal} +\alias{preferredPolesByIdeal} +\title{Set preferred pole by ideal element} +\usage{ +preferredPolesByIdeal(x, ideal, none_range = NULL, align = FALSE) +} +\arguments{ +\item{x}{A \code{repgrid} object.} + +\item{ideal}{Index or name of ideal element.} + +\item{none_range}{Range of ratings that do not allow assining a preferred pole (\code{NULL} be default).} + +\item{align}{Align preferred poles on same side (default \code{FALSE}). See \code{\link[=alignByPreferredPoles]{alignByPreferredPoles()}}.} +} +\description{ +The preferred construct pole is inferred from the rating of the ideal element. +The preferred pole is the side of the ideal element. If the ideal is rated on the +scale midpoint (or within \code{none_range}), none of the poles is preferred. +} diff --git a/man/stop_if_not_in_element_range.Rd b/man/stop_if_not_in_element_range.Rd new file mode 100644 index 0000000..d28be73 --- /dev/null +++ b/man/stop_if_not_in_element_range.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/repgrid-basicops.r +\name{stop_if_not_in_element_range} +\alias{stop_if_not_in_element_range} +\title{Raise error if element index is outside of range or element name is unknown} +\usage{ +stop_if_not_in_element_range(x, element) +} +\arguments{ +\item{x}{A `repgrid``` object.} + +\item{element}{Element index or name.} +} +\description{ +Raise error if element index is outside of range or element name is unknown +} +\keyword{internal} diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R new file mode 100644 index 0000000..74badb6 --- /dev/null +++ b/tests/testthat/test-helpers.R @@ -0,0 +1,16 @@ +test_that("stop_if_not_in_element_range", { + + expect_no_error({ + stop_if_not_in_element_range(boeker, 1) + stop_if_not_in_element_range(boeker, "self") + }) + + expect_error(stop_if_not_in_element_range(boeker, -1)) + expect_error(stop_if_not_in_element_range(boeker, 16)) + expect_error(stop_if_not_in_element_range(boeker, NA)) + expect_error(stop_if_not_in_element_range(boeker, "xxx")) + expect_error(stop_if_not_in_element_range(boeker, 1.1)) +}) + + + diff --git a/tests/testthat/test-preferred-pole.R b/tests/testthat/test-preferred-pole.R new file mode 100644 index 0000000..d675e27 --- /dev/null +++ b/tests/testthat/test-preferred-pole.R @@ -0,0 +1,20 @@ +test_that("preferredPoles", { + x <- boeker + nc <- nrow(x) + + preferredPoles(x) <- "left" + expect_equal(preferredPoles(x), rep_len("left", nc)) + + xr <- reverse(x) + expect_equal(preferredPoles(xr), rep_len("right", nc)) + + preferredPoles(x) <- "none" + expect_equal(preferredPoles(x), rep_len("none", nc)) + + preferredPoles(x) <- "both" + expect_equal(preferredPoles(x), rep_len("both", nc)) + + preferredPoles(x) <- NA + expect_equal(preferredPoles(x), rep_len(NA_character_, nc)) +}) + From a23a83d05c7d98f6e13bba706407956c2c0630da Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Sun, 11 May 2025 10:27:52 +0200 Subject: [PATCH 13/23] tweak --- man/showMeta.Rd | 25 ------------------------- 1 file changed, 25 deletions(-) delete mode 100644 man/showMeta.Rd diff --git a/man/showMeta.Rd b/man/showMeta.Rd deleted file mode 100644 index 5cb640d..0000000 --- a/man/showMeta.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/repgrid-basicops.r -\name{showMeta} -\alias{showMeta} -\title{showMeta} -\usage{ -showMeta(x) -} -\arguments{ -\item{x}{repgrid object} -} -\value{ -\code{NULL} -} -\description{ -prints meta information about the grid to the console (id, name of interviewee etc.) -} -\examples{ -\dontrun{ - -#### TODO #### -} - -} -\keyword{internal} From b25b4aef0ff363eba87fc755ff52acf3a7a30998 Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Sun, 11 May 2025 12:30:08 +0200 Subject: [PATCH 14/23] preferred pole: indicator in print.repgrid addition setting 'preferred' to turn on/off --- R/preferred_poles.R | 21 +++++++++++ R/repgrid-output.r | 90 +++++++++++++++++++++++++-------------------- R/settings.r | 12 ++++-- man/settings.Rd | 3 +- 4 files changed, 81 insertions(+), 45 deletions(-) diff --git a/R/preferred_poles.R b/R/preferred_poles.R index a983b11..8cfc7a6 100644 --- a/R/preferred_poles.R +++ b/R/preferred_poles.R @@ -32,6 +32,27 @@ preferredPoles <- function(x) { } +# short form preference indicators for repgrid show method +preferred_indicators <- function(x) { + preferred <- preferredPoles(x) + indicators_left <- case_when( + preferred == "left" ~ "+", + preferred == "both" ~ "+", + preferred == "none" ~ "/", + preferred == "right" ~ "-", + is.na(NA) ~ "." + ) + indicators_right <- case_when( + preferred == "left" ~ "-", + preferred == "both" ~ "+", + preferred == "none" ~ "/", + preferred == "right" ~ "+", + is.na(NA) ~ "." + ) + list(left = indicators_left, right = indicators_right) +} + + #' Set preferred pole by ideal element #' #' The preferred construct pole is inferred from the rating of the ideal element. diff --git a/R/repgrid-output.r b/R/repgrid-output.r index 3fe0c2f..22c4600 100644 --- a/R/repgrid-output.r +++ b/R/repgrid-output.r @@ -191,6 +191,15 @@ colorize_matrix_rows <- function(m, colors = "white", na.val = "white") { } +colorize <- function(x, color) { + if (!crayon::has_color()) { + return(x) + } + color <- match.arg(color, c("black", "red", "green", "yellow", "blue", "magenta", "cyan", "white", "silver")) + match.fun(color)(x) +} + + df_out <- function(df, # data frame left = NA, # rows left right = NA, # rows right @@ -209,7 +218,8 @@ df_out <- function(df, # data frame 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 + id = c(TRUE, TRUE), # id numbers at beginning/end of each row/column + show_preferred = TRUE, # show preferred pole if exsist hatform = FALSE, # column names in hat form grid) # repgrid object { @@ -254,16 +264,23 @@ df_out <- function(df, # data frame # 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") { + # preferred vector with preference indicators + make_mat_leftright <- function(vec, show_id = TRUE, idside = 1, trim = NA, just = "r", preferred = "", show_preferred) { 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 = "") + preferred_pre <- if (idside == 2 && show_preferred) preferred else "" + preferred_post <- if (idside == 1 && show_preferred) preferred else "" + + ids <- if (show_id) seq_along(vec) else "" + if (show_id || show_preferred) { # add id number to each row + .open <- "(" + .close <- ")" + info <- paste(.open, preferred_pre, ids, preferred_post, .close, sep = "") if (idside == 1) { # ids at start of string (for right side constructs) - vec <- paste(ids, vec) + vec <- paste(info, vec) } else { - vec <- paste(vec, ids) + vec <- paste(vec, info) } # ids at end of string (for left side constructs) } vec <- format(vec, justify = just) # justify rownames @@ -284,27 +301,34 @@ df_out <- function(df, # data frame # decision where and how to put left and right vectors if (showopt == 1) { # #1 left to left, right to right + pref <- preferred_indicators(grid) if (!identical(left, NA)) { - mat.left <- make_mat_leftright(left, id = id[1], idside = 2, just = "r") + mat.left <- make_mat_leftright(left, + show_id = id[1], idside = 2, just = "r", + preferred = pref$left, show_preferred = show_preferred + ) } if (!identical(right, NA)) { - mat.right <- make_mat_leftright(right, id = id[1], idside = 1, just = "l") + mat.right <- make_mat_leftright(right, + show_id = id[1], idside = 1, just = "l", + preferred = pref$right, show_preferred = show_preferred + ) } } 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") + mat.left <- make_mat_leftright(leftright, show_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") + mat.left <- make_mat_leftright(right, show_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") + mat.left <- make_mat_leftright(left, show_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") + mat.right <- make_mat_leftright(leftright, show_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") + mat.right <- make_mat_leftright(right, show_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") + mat.right <- make_mat_leftright(left, show_id = id[1], idside = 1, just = "l") } } # #0 left and right unused, mat.left and mat.right remain void @@ -448,7 +472,7 @@ df_out <- function(df, # data frame preferred == "none" ~ "white", preferred == "right" ~ "red", is.na(NA) ~ "white" - ) + ) colors_pole_right <- case_when( preferred == "right" ~ "green", preferred == "both" ~ "green", @@ -499,6 +523,14 @@ df_out <- function(df, # data frame mat.out.atomic <- mat.out.atomic[, end.left:end.right] } break_output(mat.out.atomic) + + if (show_preferred) { + s_1 <- colorize("(+) = preferred", "green") + s_2 <- colorize("(-) = non-preferred", "red") + s_3 <- colorize("(/) = none", "white") + s_4 <- colorize("(.) = not defined", "white") + cat("\nPoles:", paste(s_1, ",", s_2, ",",s_3, ",", s_4)) + } invisible(NULL) } @@ -512,29 +544,6 @@ df_out <- function(df, # data frame # 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 `repgrid` object -# @docType methods -# @usage \S4method{show}{repgrid}(object) -# @include repgrid.r -# - #' Show method for repgrid #' #' @param object A `repgrid` object. @@ -547,7 +556,8 @@ setMethod("show", "repgrid", function(object) { 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 + hatform <- TRUE + show_preferred <- pars$preferred x <- object do.bertin <- FALSE @@ -570,7 +580,7 @@ setMethod("show", "repgrid", function(object) { df_out(df.ratings, left, right, just.main = "r", hatform = hatform, id = id, trim = trim, cut = cut, equal = FALSE, showopt = showopt, - grid = x + grid = x, show_preferred = show_preferred ) cat("\n") if (do.bertin) { diff --git a/R/settings.r b/R/settings.r index 77de51f..55a9865 100644 --- a/R/settings.r +++ b/R/settings.r @@ -11,10 +11,12 @@ generateDefaultSettings <- function() { 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" + l$c.no <- TRUE + type$c.no <- "logical" + l$preferred <- TRUE + type$preferred <- "logical" class(l) <- "openrepgridSettings" attr(l, "type") <- type @@ -74,8 +76,9 @@ setDefaultSettings <- function() { #' - `show.meta`: Show grid meta data? (`TRUE`) #' - `show.trim`: Number of chars to trim strings to (`30`) #' - `show.cut`: Maximum number of characters printed on the sides of a grid (`20`) -#' - `c.no`: Print construct ID number? (`TRUE`) #' - `e.no`: Print element ID number? (`TRUE`) +#' - `c.no`: Print construct ID number? (`TRUE`) +#' - `preferred`: Print preferred pole indicator? (`TRUE`) #' #' @export #' @examples \dontrun{ @@ -153,8 +156,9 @@ print.openrepgridSettings <- function(x, ...) { 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") + if (!is.null(x$c.no)) cat("\tc.no :", x$c.no, "(print construct id?)\n") + if (!is.null(x$preferred)) cat("\tpreferred :", x$c.no, "(print preferred pole indicator?)\n") } diff --git a/man/settings.Rd b/man/settings.Rd index 769e038..3ac817b 100644 --- a/man/settings.Rd +++ b/man/settings.Rd @@ -22,8 +22,9 @@ The default value is shown in the brackets at the end of a line. \item \code{show.meta}: Show grid meta data? (\code{TRUE}) \item \code{show.trim}: Number of chars to trim strings to (\code{30}) \item \code{show.cut}: Maximum number of characters printed on the sides of a grid (\code{20}) -\item \code{c.no}: Print construct ID number? (\code{TRUE}) \item \code{e.no}: Print element ID number? (\code{TRUE}) +\item \code{c.no}: Print construct ID number? (\code{TRUE}) +\item \code{preferred}: Print preferred pole indicator? (\code{TRUE}) } } \examples{ From 441af16b7c9a42222880d8fa727799d3d4dac47d Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Sun, 11 May 2025 12:31:27 +0200 Subject: [PATCH 15/23] run styler --- R/preferred_poles.R | 9 +++++---- R/repgrid-basicops.r | 6 +++--- R/repgrid-output.r | 2 +- R/rgl-3d.r | 1 - tests/testthat/test-calc.R | 2 -- tests/testthat/test-helpers.R | 4 ---- tests/testthat/test-preferred-pole.R | 1 - tests/testthat/test_biplot.R | 1 - 8 files changed, 9 insertions(+), 17 deletions(-) diff --git a/R/preferred_poles.R b/R/preferred_poles.R index 8cfc7a6..1527037 100644 --- a/R/preferred_poles.R +++ b/R/preferred_poles.R @@ -1,4 +1,3 @@ - preferredPoles <- function(x) { stop_if_not_is_repgrid(x) left_is_preferred <- sapply(x@constructs, function(c) c$leftpole$preferred) @@ -106,15 +105,17 @@ preferredPolesByIdeal <- function(x, ideal, none_range = NULL, align = FALSE) { #' @export #' @seealso [alignByLoadings()] #' @examples -#' #TBD +#' # TBD alignByPreferredPole <- function(x, side = "right") { stop_if_not_is_repgrid(x) side <- match.arg(side, c("left", "right")) preferred_poles <- preferredPoles(x) ii_na <- is.na(preferred_poles) if (any(ii_na)) { - warning(c("Some construct do not have a preferred pole and were not aligned.\n", - "See 'preferredPoles() to set a preference'"), call. = FALSE) + warning(c( + "Some construct do not have a preferred pole and were not aligned.\n", + "See 'preferredPoles() to set a preference'" + ), call. = FALSE) } if (side == "left") { ii_reverse <- preferred_poles == "right" diff --git a/R/repgrid-basicops.r b/R/repgrid-basicops.r index fdae763..a7a4262 100644 --- a/R/repgrid-basicops.r +++ b/R/repgrid-basicops.r @@ -74,7 +74,7 @@ stop_if_not_in_element_range <- function(x, element) { stop("element name '", element, " 'is not unknown", call. = FALSE) } if (is.numeric(element) && !is_integerish(element)) { - stop("element index must be an integer", call. = FALSE) + stop("element index must be an integer", call. = FALSE) } ii <- seq_along(.elements) if (is.numeric(element) && !element %in% ii) { @@ -91,7 +91,7 @@ stop_if_not_integerish <- function(x, arg = NULL) { } else { argname <- "" } - stop("Expected integerish value ", argname, "but got '", class(x)[1], "'", call. = FALSE) + stop("Expected integerish value ", argname, "but got '", class(x)[1], "'", call. = FALSE) } } @@ -1616,7 +1616,7 @@ cbind.repgrid <- function(..., .reorder = TRUE, .unique = FALSE) { bindElements <- function(..., .reorder = TRUE, .unique = FALSE) { - dots <- unlist(list(...)) # in case list of repgrid objects are supplied + dots <- unlist(list(...)) # in case list of repgrid objects are supplied is.grid <- sapply(dots, function(x) inherits(x, "repgrid")) .f <- function(x, y) { bindTwoElements(x, y, .reorder = .reorder, .unique = .unique) diff --git a/R/repgrid-output.r b/R/repgrid-output.r index 22c4600..1ded897 100644 --- a/R/repgrid-output.r +++ b/R/repgrid-output.r @@ -529,7 +529,7 @@ df_out <- function(df, # data frame s_2 <- colorize("(-) = non-preferred", "red") s_3 <- colorize("(/) = none", "white") s_4 <- colorize("(.) = not defined", "white") - cat("\nPoles:", paste(s_1, ",", s_2, ",",s_3, ",", s_4)) + cat("\nPoles:", paste(s_1, ",", s_2, ",", s_3, ",", s_4)) } invisible(NULL) } diff --git a/R/rgl-3d.r b/R/rgl-3d.r index 8d2a853..cdadd57 100644 --- a/R/rgl-3d.r +++ b/R/rgl-3d.r @@ -149,7 +149,6 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. lef = 1.1, frame = 1, col.frame = grey(.6), col.sphere = "black", alpha.sphere = .05, zoom = 1, draw.xyz.axes = TRUE, ...) { - if (!requireNamespace("rgl", quietly = TRUE)) { stop("The 'rgl' package is required to use OpenRepGrid's 3D features => please install 'rgl'.", call. = FALSE) } diff --git a/tests/testthat/test-calc.R b/tests/testthat/test-calc.R index b2c2ebc..e55971e 100644 --- a/tests/testthat/test-calc.R +++ b/tests/testthat/test-calc.R @@ -1,7 +1,5 @@ - # test for issues #22 and #31 (constructs were missing after align) test_that("align()", { - sorted_poles <- function(x) { df_con <- constructs(x) l <- as.list(as.data.frame(t(df_con))) # df rows as list diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-helpers.R index 74badb6..95ebc22 100644 --- a/tests/testthat/test-helpers.R +++ b/tests/testthat/test-helpers.R @@ -1,5 +1,4 @@ test_that("stop_if_not_in_element_range", { - expect_no_error({ stop_if_not_in_element_range(boeker, 1) stop_if_not_in_element_range(boeker, "self") @@ -11,6 +10,3 @@ test_that("stop_if_not_in_element_range", { expect_error(stop_if_not_in_element_range(boeker, "xxx")) expect_error(stop_if_not_in_element_range(boeker, 1.1)) }) - - - diff --git a/tests/testthat/test-preferred-pole.R b/tests/testthat/test-preferred-pole.R index d675e27..5f69585 100644 --- a/tests/testthat/test-preferred-pole.R +++ b/tests/testthat/test-preferred-pole.R @@ -17,4 +17,3 @@ test_that("preferredPoles", { preferredPoles(x) <- NA expect_equal(preferredPoles(x), rep_len(NA_character_, nc)) }) - diff --git a/tests/testthat/test_biplot.R b/tests/testthat/test_biplot.R index 4da8973..f468b3a 100644 --- a/tests/testthat/test_biplot.R +++ b/tests/testthat/test_biplot.R @@ -3,7 +3,6 @@ library(vdiffr) test_that("biplots work", { - create_biplot2d <- function() { set.seed(0) biplot2d(boeker) From b7ca874b13958523d8b15cc3b89b0a409fbe7026 Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Sun, 11 May 2025 13:41:12 +0200 Subject: [PATCH 16/23] preferred poles: add tests, examples, docs --- NAMESPACE | 2 + R/preferred_poles.R | 98 +++++++++++-------- R/utils.r | 27 +++++ inst/examples/example-preferredPoles.R | 16 +++ man/alignByPreferredPole.Rd | 6 +- man/preferred-pole.Rd | 39 ++++++++ man/preferredPolesByIdeal.Rd | 2 +- .../testthat/{test-helpers.R => test-utils.R} | 17 ++++ 8 files changed, 162 insertions(+), 45 deletions(-) create mode 100644 inst/examples/example-preferredPoles.R create mode 100644 man/preferred-pole.Rd rename tests/testthat/{test-helpers.R => test-utils.R} (52%) diff --git a/NAMESPACE b/NAMESPACE index 6f80071..639d774 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -35,6 +35,7 @@ S3method(rep,repgrid) export("constructs<-") export("elements<-") export("leftpoles<-") +export("preferredPoles<-") export("ratings<-") export("rightpoles<-") export(addAvgElement) @@ -151,6 +152,7 @@ export(orderByString) export(permuteConstructs) export(permuteGrid) export(perturbate) +export(preferredPoles) export(preferredPolesByIdeal) export(prepareBiplotData) export(print_square_matrix) diff --git a/R/preferred_poles.R b/R/preferred_poles.R index 1527037..87588af 100644 --- a/R/preferred_poles.R +++ b/R/preferred_poles.R @@ -1,3 +1,14 @@ +#' Get / set preferred construct poles +#' +#' Constructs are bipolar, often with one pole being preferred (positive). +#' Setting the preferred poles may be useful for some analyses. +#' +#' @param x A `repgrid` object. +#' @param value Vector of with preferred poles. One of `'left'`, `'right'`, `'none'` or `NA`. +#' Abbreviations are allowsd (`'l'` for `'left'`). +#' @export +#' @rdname preferred-pole +#' @example inst/examples/example-preferredPoles.R preferredPoles <- function(x) { stop_if_not_is_repgrid(x) left_is_preferred <- sapply(x@constructs, function(c) c$leftpole$preferred) @@ -12,6 +23,8 @@ preferredPoles <- function(x) { } +#' @export +#' @rdname preferred-pole `preferredPoles<-` <- function(x, value) { stop_if_not_is_repgrid(x) nc <- nrow(x) @@ -52,6 +65,46 @@ preferred_indicators <- function(x) { } +#' Align constructs by preferred pole +#' +#' The direction of the constructs in a grid is arbitrary. While their reversal (see [reverse()]) does not affect the information +#' contained in the grid, it is often useful to align constructs for easier interpretation. One way of alignment +#' is placing all positive poles on the same side. Note that this this is only possible if the preferred poles +#' are defined (see [preferredPoles()]). +#' +#' @param x A `repgrid` object. +#' @param side_positive Align all positoive poles on ' +#' @return A `repgrid` object with aligned constructs. +#' @export +#' @seealso [alignByLoadings()] +#' @examples +#' x <- preferredPolesByIdeal(boeker, "ideal self") +#' x <- alignByPreferredPole(x) +#' x +alignByPreferredPole <- function(x, side_positive = "right") { + stop_if_not_is_repgrid(x) + side_positive <- match.arg(side_positive, c("left", "right")) + preferred_poles <- preferredPoles(x) + ii_na <- is.na(preferred_poles) + if (any(ii_na)) { + warning(c( + "Some construct do not have a preferred pole and were not aligned.\n", + "See 'preferredPoles() to set a preference'" + ), call. = FALSE) + } + if (side_positive == "left") { + ii_reverse <- preferred_poles == "right" + } else { + ii_reverse <- preferred_poles == "left" + } + ii_reverse <- which(ii_reverse) + if (length(ii_reverse) > 0) { + x <- reverse(x, ii_reverse) + } + x +} + + #' Set preferred pole by ideal element #' #' The preferred construct pole is inferred from the rating of the ideal element. @@ -61,12 +114,12 @@ preferred_indicators <- function(x) { #' @param x A `repgrid` object. #' @param ideal Index or name of ideal element. #' @param none_range Range of ratings that do not allow assining a preferred pole (`NULL` be default). -#' @param align Align preferred poles on same side (default `FALSE`). See [alignByPreferredPoles()]. +#' @param align Align preferred poles on same side (default `FALSE`). See [alignByPreferredPole()]. #' @export preferredPolesByIdeal <- function(x, ideal, none_range = NULL, align = FALSE) { stop_if_not_is_repgrid(x) stop_if_not_in_element_range(x, ideal) - + ideal <- fortify_element_id(x, ideal) midpoint <- getScaleMidpoint(x) sc <- getScale(x) if (is.null(none_range)) { @@ -74,7 +127,6 @@ preferredPolesByIdeal <- function(x, ideal, none_range = NULL, align = FALSE) { } else { stop_if_not_integerish(none_range, arg = "none_range") } - idealRatings <- ratings(x)[, ideal] preferred_pole <- case_when( idealRatings %in% none_range ~ "none", @@ -86,45 +138,7 @@ preferredPolesByIdeal <- function(x, ideal, none_range = NULL, align = FALSE) { preferredPoles(x) <- preferred_pole if (align) { - x <- alignByPreferredPoles(x) - } - x -} - - -#' Align constructs by preferred pole -#' -#' The direction of the constructs in a grid is arbitrary. While their reversal (see [reverse()]) does not affect the information -#' contained in the grid, it is often useful to align constructs for easier interpretation. One way of alignment -#' is placing all positive poles on the same side. Note that this this is only possible if the preferred poles -#' are defined (see [preferredPoles()]). -#' -#' @param x A `repgrid` object. -#' @param side_positive Align all positoive poles on ' -#' @return A `repgrid` object with aligned constructs. -#' @export -#' @seealso [alignByLoadings()] -#' @examples -#' # TBD -alignByPreferredPole <- function(x, side = "right") { - stop_if_not_is_repgrid(x) - side <- match.arg(side, c("left", "right")) - preferred_poles <- preferredPoles(x) - ii_na <- is.na(preferred_poles) - if (any(ii_na)) { - warning(c( - "Some construct do not have a preferred pole and were not aligned.\n", - "See 'preferredPoles() to set a preference'" - ), call. = FALSE) - } - if (side == "left") { - ii_reverse <- preferred_poles == "right" - } else { - ii_reverse <- preferred_poles == "left" - } - ii_reverse <- which(ii_reverse) - if (length(ii_reverse) > 0) { - x <- reverse(x, ii_reverse) + x <- alignByPreferredPole(x) } x } diff --git a/R/utils.r b/R/utils.r index d80372f..34a8b40 100644 --- a/R/utils.r +++ b/R/utils.r @@ -844,6 +844,33 @@ is_integerish <- function(x) { } +#' convert element index or name to index +#' @examples +#' fortify_element_id(boeker, "self") +#' fortify_element_id(boeker, 1) +#' @noRd +fortify_element_id <- function(x, element) { + stop_if_not_in_element_range(x, element) + if (is.character(element)) { + element <- which(elements(x) == element) + } + element +} + + +#' convert element index or name to name +#' @examples +#' fortify_element_name(boeker, 1) +#' fortify_element_name(boeker, "self") +#' @noRd +fortify_element_name <- function(x, element) { + stop_if_not_in_element_range(x, element) + if (is.numeric(element)) { + element <- elements(x)[element] + } + element +} + # ////////////////////////////////////////////////////////////////////////////// ### FORMATTING #### diff --git a/inst/examples/example-preferredPoles.R b/inst/examples/example-preferredPoles.R new file mode 100644 index 0000000..5efa602 --- /dev/null +++ b/inst/examples/example-preferredPoles.R @@ -0,0 +1,16 @@ +x <- fbb2003 + +preferredPoles(x) # no preferences assigned yet + +# set preference by ideal rating +x <- preferredPolesByIdeal(x, ideal = "as I would love to be") +x <- preferredPolesByIdeal(x, ideal = 7) # same with element index +x + +# set preferred poles manually +preferredPoles(x) <- c("left", "right", "left", "r", "l", "l", "l", "r", "r") +x + +# change preferance for constructs 1 and 5 +preferredPoles(x)[2] <- "left" +x diff --git a/man/alignByPreferredPole.Rd b/man/alignByPreferredPole.Rd index ac7cee6..5f2e38f 100644 --- a/man/alignByPreferredPole.Rd +++ b/man/alignByPreferredPole.Rd @@ -4,7 +4,7 @@ \alias{alignByPreferredPole} \title{Align constructs by preferred pole} \usage{ -alignByPreferredPole(x, side = "right") +alignByPreferredPole(x, side_positive = "right") } \arguments{ \item{x}{A \code{repgrid} object.} @@ -21,7 +21,9 @@ is placing all positive poles on the same side. Note that this this is only poss are defined (see \code{\link[=preferredPoles]{preferredPoles()}}). } \examples{ -#TBD +x <- preferredPolesByIdeal(boeker, "ideal self") +x <- alignByPreferredPole(x) +x } \seealso{ \code{\link[=alignByLoadings]{alignByLoadings()}} diff --git a/man/preferred-pole.Rd b/man/preferred-pole.Rd new file mode 100644 index 0000000..31db22a --- /dev/null +++ b/man/preferred-pole.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/preferred_poles.R +\name{preferredPoles} +\alias{preferredPoles} +\alias{preferredPoles<-} +\title{Get / set preferred construct poles} +\usage{ +preferredPoles(x) + +preferredPoles(x) <- value +} +\arguments{ +\item{x}{A \code{repgrid} object.} + +\item{value}{Vector of with preferred poles. One of \code{'left'}, \code{'right'}, \code{'none'} or \code{NA}. +Abbreviations are allowsd (\code{'l'} for \code{'left'}).} +} +\description{ +Constructs are bipolar, often with one pole being preferred (positive). +Setting the preferred poles may be useful for some analyses. +} +\examples{ +x <- fbb2003 + +preferredPoles(x) # no preferences assigned yet + +# set preference by ideal rating +x <- preferredPolesByIdeal(x, ideal = "as I would love to be") +x <- preferredPolesByIdeal(x, ideal = 7) # same with element index +x + +# set preferred poles manually +preferredPoles(x) <- c("left", "right", "left", "r", "l", "l", "l", "r", "r") +x + +# change preferance for constructs 1 and 5 +preferredPoles(x)[2] <- "left" +x +} diff --git a/man/preferredPolesByIdeal.Rd b/man/preferredPolesByIdeal.Rd index f9ac872..64c1039 100644 --- a/man/preferredPolesByIdeal.Rd +++ b/man/preferredPolesByIdeal.Rd @@ -13,7 +13,7 @@ preferredPolesByIdeal(x, ideal, none_range = NULL, align = FALSE) \item{none_range}{Range of ratings that do not allow assining a preferred pole (\code{NULL} be default).} -\item{align}{Align preferred poles on same side (default \code{FALSE}). See \code{\link[=alignByPreferredPoles]{alignByPreferredPoles()}}.} +\item{align}{Align preferred poles on same side (default \code{FALSE}). See \code{\link[=alignByPreferredPole]{alignByPreferredPole()}}.} } \description{ The preferred construct pole is inferred from the rating of the ideal element. diff --git a/tests/testthat/test-helpers.R b/tests/testthat/test-utils.R similarity index 52% rename from tests/testthat/test-helpers.R rename to tests/testthat/test-utils.R index 95ebc22..d511ba4 100644 --- a/tests/testthat/test-helpers.R +++ b/tests/testthat/test-utils.R @@ -10,3 +10,20 @@ test_that("stop_if_not_in_element_range", { expect_error(stop_if_not_in_element_range(boeker, "xxx")) expect_error(stop_if_not_in_element_range(boeker, 1.1)) }) + + +test_that("fortify_element_*", { + x <- boeker + nr <- nrow(x) + ee <- elements(x) + for (i in seq_len(nr)) { + e <- ee[i] + expect_equal(fortify_element_id(x, i), i) + expect_equal(fortify_element_id(x, e), i) + expect_equal(fortify_element_name(x, i), e) + expect_equal(fortify_element_name(x, e), e) + } + + expect_error(fortify_element_id(x, -1)) + expect_error(fortify_element_name(x, "xxx")) +}) From 52cc807d2b5b4efa2487170efe9c1d6793b6ffa1 Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Sun, 11 May 2025 14:24:29 +0200 Subject: [PATCH 17/23] improve docs --- R/calc.r | 4 ++-- R/preferred_poles.R | 6 +++--- inst/examples/example-preferredPoles.R | 4 ++++ man/alignByIdeal.Rd | 5 ++++- man/alignByLoadings.Rd | 5 ++++- man/alignByPreferredPole.Rd | 5 ++++- man/preferred-pole.Rd | 8 ++++++-- man/roxygen/meta.R | 3 +++ 8 files changed, 30 insertions(+), 10 deletions(-) create mode 100644 man/roxygen/meta.R diff --git a/R/calc.r b/R/calc.r index 6b40e67..e5ebae6 100644 --- a/R/calc.r +++ b/R/calc.r @@ -934,7 +934,7 @@ print.constructPca <- function(x, digits = 2, cutoff = 0, ...) { #' *International Journal of Personal Construct Psychology, 5*(1), 57-75. #' #' @export -#' @seealso [alignByIdeal()] +#' @family align_constructs #' @examples #' #' # reproduction of the example in the Bell (2010) @@ -1049,7 +1049,7 @@ print.alignByLoadings <- function(x, digits = 2, col.index = TRUE, ...) { #' middle way? *Journal of Constructivist Psychology, 23*(4), 337-356. #' #' @export -#' @seealso [alignByLoadings()] +#' @family align_constructs #' @examples #' #' feixas2004 # original grid diff --git a/R/preferred_poles.R b/R/preferred_poles.R index 87588af..20a8461 100644 --- a/R/preferred_poles.R +++ b/R/preferred_poles.R @@ -1,7 +1,7 @@ #' Get / set preferred construct poles #' -#' Constructs are bipolar, often with one pole being preferred (positive). -#' Setting the preferred poles may be useful for some analyses. +#' Constructs are bipolar, usually with one pole being preferred (positive). +#' Setting the preferred poles may is useful in some analyses. #' #' @param x A `repgrid` object. #' @param value Vector of with preferred poles. One of `'left'`, `'right'`, `'none'` or `NA`. @@ -76,7 +76,7 @@ preferred_indicators <- function(x) { #' @param side_positive Align all positoive poles on ' #' @return A `repgrid` object with aligned constructs. #' @export -#' @seealso [alignByLoadings()] +#' @family align_constructs #' @examples #' x <- preferredPolesByIdeal(boeker, "ideal self") #' x <- alignByPreferredPole(x) diff --git a/inst/examples/example-preferredPoles.R b/inst/examples/example-preferredPoles.R index 5efa602..08371cf 100644 --- a/inst/examples/example-preferredPoles.R +++ b/inst/examples/example-preferredPoles.R @@ -14,3 +14,7 @@ x # change preferance for constructs 1 and 5 preferredPoles(x)[2] <- "left" x + +# remove prefernces +preferredPoles(x) <- NA +x diff --git a/man/alignByIdeal.Rd b/man/alignByIdeal.Rd index dd4b505..95e8fe8 100644 --- a/man/alignByIdeal.Rd +++ b/man/alignByIdeal.Rd @@ -48,5 +48,8 @@ Winter, D. A., Bell, R. C., & Watson, S. (2010). Midpoint ratings on personal co middle way? \emph{Journal of Constructivist Psychology, 23}(4), 337-356. } \seealso{ -\code{\link[=alignByLoadings]{alignByLoadings()}} +Aligning constructs +\code{\link{alignByLoadings}()}, +\code{\link{alignByPreferredPole}()} } +\concept{align_constructs} diff --git a/man/alignByLoadings.Rd b/man/alignByLoadings.Rd index 6312c0b..6c93b67 100644 --- a/man/alignByLoadings.Rd +++ b/man/alignByLoadings.Rd @@ -72,5 +72,8 @@ Mackay, N. (1992). Identification, Reflection, and Correlation: Problems in the \emph{International Journal of Personal Construct Psychology, 5}(1), 57-75. } \seealso{ -\code{\link[=alignByIdeal]{alignByIdeal()}} +Aligning constructs +\code{\link{alignByIdeal}()}, +\code{\link{alignByPreferredPole}()} } +\concept{align_constructs} diff --git a/man/alignByPreferredPole.Rd b/man/alignByPreferredPole.Rd index 5f2e38f..524682f 100644 --- a/man/alignByPreferredPole.Rd +++ b/man/alignByPreferredPole.Rd @@ -26,5 +26,8 @@ x <- alignByPreferredPole(x) x } \seealso{ -\code{\link[=alignByLoadings]{alignByLoadings()}} +Aligning constructs +\code{\link{alignByIdeal}()}, +\code{\link{alignByLoadings}()} } +\concept{align_constructs} diff --git a/man/preferred-pole.Rd b/man/preferred-pole.Rd index 31db22a..98f8aa8 100644 --- a/man/preferred-pole.Rd +++ b/man/preferred-pole.Rd @@ -16,8 +16,8 @@ preferredPoles(x) <- value Abbreviations are allowsd (\code{'l'} for \code{'left'}).} } \description{ -Constructs are bipolar, often with one pole being preferred (positive). -Setting the preferred poles may be useful for some analyses. +Constructs are bipolar, usually with one pole being preferred (positive). +Setting the preferred poles may is useful in some analyses. } \examples{ x <- fbb2003 @@ -36,4 +36,8 @@ x # change preferance for constructs 1 and 5 preferredPoles(x)[2] <- "left" x + +# remove prefernces +preferredPoles(x) <- NA +x } diff --git a/man/roxygen/meta.R b/man/roxygen/meta.R new file mode 100644 index 0000000..44900ab --- /dev/null +++ b/man/roxygen/meta.R @@ -0,0 +1,3 @@ +list( + rd_family_title = list(align_constructs = "Aligning constructs") +) From 66eff833698412c80f4d490f33d5726ade02bfa6 Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Mon, 12 May 2025 13:19:00 +0200 Subject: [PATCH 18/23] `importTxt` imports preferred poles (#57) --- DESCRIPTION | 4 +- NEWS.md | 1 + R/import.r | 22 +++++++++ R/preferred_poles.R | 2 +- R/utils.r | 5 +++ tests/testthat/test-import.R | 26 +++++++++++ tests/testthat/testdata/grid_no_preferred.txt | 36 +++++++++++++++ tests/testthat/testdata/grid_preferred.txt | 45 +++++++++++++++++++ .../testdata/grid_preferred_incorrect_1.txt | 45 +++++++++++++++++++ .../testdata/grid_preferred_incorrect_2.txt | 45 +++++++++++++++++++ 10 files changed, 228 insertions(+), 3 deletions(-) create mode 100644 tests/testthat/test-import.R create mode 100644 tests/testthat/testdata/grid_no_preferred.txt create mode 100644 tests/testthat/testdata/grid_preferred.txt create mode 100644 tests/testthat/testdata/grid_preferred_incorrect_1.txt create mode 100644 tests/testthat/testdata/grid_preferred_incorrect_2.txt diff --git a/DESCRIPTION b/DESCRIPTION index 5ae7799..1289d6b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,8 +16,8 @@ Description: Analyze repertory grids, a qualitative-quantitative to quantitatively analyze and visualize repertory grid data (e.g. 'Fransella', 'Bell', & 'Bannister', 2004, ISBN: 978-0-470-09080-0). The package is part of the The package is part of the project. -Version: 0.1.18.9005 -Date: 2025-05-08 +Version: 0.1.18.9006 +Date: 2025-05-12 Encoding: UTF-8 URL: https://github.com/markheckmann/OpenRepGrid Imports: diff --git a/NEWS.md b/NEWS.md index 4e02330..7118dc5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,6 @@ # OpenRepGrid 0.1.18 (dev version) +* `importTxt` reads preferred poles from section `PREFERRED` (#57) * `preferredPoles` sets the preferred construct poles, `preferredPolesByIdeal` sets the preferred pole bases on the ideal elements ratings, `alignByPreferredPole` aligns constructs by pole preference (#57) * `biplot3d`: New args `e.sphere.show`, `e.labels.show`, `c.axis.show`. `c.sphere.show`. Construct spheres now hidden diff --git a/R/import.r b/R/import.r index 18c6b33..e2fc6fa 100644 --- a/R/import.r +++ b/R/import.r @@ -34,6 +34,7 @@ convertImportObjectToRepGridObject <- function(import) { # List of 9 # $ elements :List of 3 # $ constructs :List of 4 + # $ preferred :List of 4 # $ emergentPoles:List of 4 # $ contrastPoles:List of 4 # $ ratings :List of 4 @@ -50,6 +51,19 @@ convertImportObjectToRepGridObject <- function(import) { ) # ratings x <- makeRepgrid(args) # make repgrid x <- setScale(x, import$minValue, import$maxValue) # set scale range + + # preferred poles + if (!is.null(import$preferred)) { + preferred <- unlist(import$preferred) + n_preferred <- length(preferred) + if (length(preferred) != nrow(x)) { + stop(c( + "\nNumber of preferred poles (", n_preferred, ") does not match number of constructs (", nrow(x), ")", + "\nPlease check section 'PREFERRED' in source file" + ), call. = FALSE) + } + preferredPoles(x) <- preferred + } x } @@ -1221,6 +1235,8 @@ importTxtInternal <- function(file, dir = NULL, min = NULL, max = NULL) { line.elements.end <- which(d == "END ELEMENTS") line.constructs <- which(d == "CONSTRUCTS") line.constructs.end <- which(d == "END CONSTRUCTS") + line.preferred <- which(d == "PREFERRED") + line.preferred.end <- which(d == "END PREFERRED") line.ratings <- which(d == "RATINGS") line.ratings.end <- which(d == "END RATINGS") line.range <- which(d == "RANGE") @@ -1242,6 +1258,12 @@ importTxtInternal <- function(file, dir = NULL, min = NULL, max = NULL) { l$emergentPoles <- lapply(tmp, function(x) trimBlanksInString(x[1])) l$contrastPoles <- lapply(tmp, function(x) trimBlanksInString(x[2])) + # read preferred poles + if (length(line.preferred) > 0 && length(line.preferred.end) > 0) { + l$preferred <- as.list(data[(line.preferred + 1):(line.preferred.end - 1)]) + l$preferred <- lapply(l$preferred, function(x) trimBlanksInString(x[1])) + } + # read ratings and convert to numeric op <- options()$warn options(warn = -1) diff --git a/R/preferred_poles.R b/R/preferred_poles.R index 20a8461..01ac437 100644 --- a/R/preferred_poles.R +++ b/R/preferred_poles.R @@ -30,7 +30,7 @@ preferredPoles <- function(x) { nc <- nrow(x) value <- rep_len(value, length.out = nc) value <- as.character(value) # all NA case - value <- match.arg(value, c("left", "right", "none", "both", NA_character_), several.ok = TRUE) + value <- match.arg2(value, c("left", "right", "none", "both", NA_character_), several.ok = TRUE) left_preferred <- value %in% c("left", "both") right_preferred <- value %in% c("right", "both") is.na(left_preferred) <- is.na(value) diff --git a/R/utils.r b/R/utils.r index 34a8b40..1851bfd 100644 --- a/R/utils.r +++ b/R/utils.r @@ -169,6 +169,11 @@ modifyListNA <- function(x, val) { # modifyListNA(l2, l1) +match.arg2 <- function(arg, choices, several.ok = TRUE) { + sapply(arg, match.arg, choices = choices, several.ok = several.ok) +} + + # ////////////////////////////////////////////////////////////////////////////// #' bring vector values into ring form #' diff --git a/tests/testthat/test-import.R b/tests/testthat/test-import.R new file mode 100644 index 0000000..12040df --- /dev/null +++ b/tests/testthat/test-import.R @@ -0,0 +1,26 @@ +test_that("importTxt - PREFERRED", { + path <- test_path("testdata/grid_no_preferred.txt") + x <- importTxt(path) + expect_equal(preferredPoles(x), rep(NA_character_, 4)) + + path <- test_path("testdata/grid_preferred.txt") + x_pref <- importTxt(path) + expect_equal(preferredPoles(x_pref), c("left", "right", "none", NA)) + + preferredPoles(x) <- preferredPoles(x_pref) + expect_identical(x, x_pref) + + path <- test_path("testdata/grid_preferred_incorrect_1.txt") + expect_error(importTxt(path), regexp = "Number of preferred poles \\(3\\) does not match number of constructs \\(4\\)") + + path <- test_path("testdata/grid_preferred_incorrect_2.txt") + expect_error(importTxt(path), regexp = "'arg' should be one of .{1}left.{1}, .{1}right.{1}, .{1}none.{1}, .{1}both.{1}, .{1}NA.{1}") +}) + + +test_that("importTxt - RATINGS", { + path <- test_path("testdata/grid_no_preferred.txt") + x <- importTxt(path) + r_same <- ratings(x) == cbind(1:4, c(2:4, 1), c(3:4, 1:2)) + expect_true(all(r_same)) +}) diff --git a/tests/testthat/testdata/grid_no_preferred.txt b/tests/testthat/testdata/grid_no_preferred.txt new file mode 100644 index 0000000..847b67b --- /dev/null +++ b/tests/testthat/testdata/grid_no_preferred.txt @@ -0,0 +1,36 @@ + +---------------- sample .txt file ----------------- + +Note: anything outside the tag pairs is discarded + +ELEMENTS +e1 +e2 +e3 +END ELEMENTS + +Note: the colon (:) seperates the construct poles + +CONSTRUCTS +l1 : r1 +l2 : r2 +l3 : r3 +l4 : r4 +END CONSTRUCTS + +Note: columns represent elements, rows constructs + +RATINGS +1 2 3 +2 3 4 +3 4 1 +4 1 2 +END RATINGS + +Note: Range means the lowest and hightest possible rating value + +RANGE +1 4 +END RANGE + +---------------- end of file ---------------- diff --git a/tests/testthat/testdata/grid_preferred.txt b/tests/testthat/testdata/grid_preferred.txt new file mode 100644 index 0000000..7e34bfc --- /dev/null +++ b/tests/testthat/testdata/grid_preferred.txt @@ -0,0 +1,45 @@ + +---------------- sample .txt file ----------------- + +Note: anything outside the tag pairs is discarded + +ELEMENTS +e1 +e2 +e3 +END ELEMENTS + +Note: the colon (:) seperates the construct poles + +CONSTRUCTS +l1 : r1 +l2 : r2 +l3 : r3 +l4 : r4 +END CONSTRUCTS + +Note: indicate the preferred pole: left, right, none, NA (=unknown) + +PREFERRED +left +r +none +NA +END PREFERRED + +Note: columns represent elements, rows constructs + +RATINGS +1 2 3 +2 3 4 +3 4 1 +4 1 2 +END RATINGS + +Note: Range means the lowest and hightest possible rating value + +RANGE +1 4 +END RANGE + +---------------- end of file ---------------- diff --git a/tests/testthat/testdata/grid_preferred_incorrect_1.txt b/tests/testthat/testdata/grid_preferred_incorrect_1.txt new file mode 100644 index 0000000..1d8dc3d --- /dev/null +++ b/tests/testthat/testdata/grid_preferred_incorrect_1.txt @@ -0,0 +1,45 @@ + +---------------- sample .txt file ----------------- + +Note: anything outside the tag pairs is discarded + +ELEMENTS +e1 +e2 +e3 +END ELEMENTS + +Note: the colon (:) seperates the construct poles + +CONSTRUCTS +l1 : r1 +l2 : r2 +l3 : r3 +l4 : r4 +END CONSTRUCTS + +Note: indicate the preferred pole: left, right, none, NA (=unknown) + +PREFERRED +left +r + +NA +END PREFERRED + +Note: columns represent elements, rows constructs + +RATINGS +1 2 3 +2 3 4 +3 4 1 +4 1 2 +END RATINGS + +Note: Range means the lowest and hightest possible rating value + +RANGE +1 4 +END RANGE + +---------------- end of file ---------------- diff --git a/tests/testthat/testdata/grid_preferred_incorrect_2.txt b/tests/testthat/testdata/grid_preferred_incorrect_2.txt new file mode 100644 index 0000000..cb925b2 --- /dev/null +++ b/tests/testthat/testdata/grid_preferred_incorrect_2.txt @@ -0,0 +1,45 @@ + +---------------- sample .txt file ----------------- + +Note: anything outside the tag pairs is discarded + +ELEMENTS +e1 +e2 +e3 +END ELEMENTS + +Note: the colon (:) seperates the construct poles + +CONSTRUCTS +l1 : r1 +l2 : r2 +l3 : r3 +l4 : r4 +END CONSTRUCTS + +Note: indicate the preferred pole: left, right, none, NA (=unknown) + +PREFERRED +left +r +xxx +NA +END PREFERRED + +Note: columns represent elements, rows constructs + +RATINGS +1 2 3 +2 3 4 +3 4 1 +4 1 2 +END RATINGS + +Note: Range means the lowest and hightest possible rating value + +RANGE +1 4 +END RANGE + +---------------- end of file ---------------- From 2eb4e27252021d9dffe43310d46b233b2458f6d2 Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Mon, 12 May 2025 18:35:01 +0200 Subject: [PATCH 19/23] `importExcel` reads preferred poles (#57) --- NEWS.md | 34 +++++------ R/import.r | 89 ++++++++++++++++++----------- inst/extdata/grid_01.txt | 9 +++ inst/extdata/grid_01.xlsx | Bin 11475 -> 9346 bytes man/importExcel.Rd | 4 +- man/importExcelInternal.Rd | 4 +- man/importTxt.Rd | 25 +++++--- tests/testthat/test-import.R | 24 ++++++++ tests/testthat/test_bertin.R | 6 +- tests/testthat/testdata/grids.xlsx | Bin 0 -> 12616 bytes 10 files changed, 129 insertions(+), 66 deletions(-) create mode 100644 tests/testthat/testdata/grids.xlsx diff --git a/NEWS.md b/NEWS.md index 7118dc5..fa1fdb0 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,6 @@ # OpenRepGrid 0.1.18 (dev version) -* `importTxt` reads preferred poles from section `PREFERRED` (#57) +* `importTxt` reads preferred poles from section `PREFERRED`, `importExcel` reads rightmost column `preferred_poles` (#57) * `preferredPoles` sets the preferred construct poles, `preferredPolesByIdeal` sets the preferred pole bases on the ideal elements ratings, `alignByPreferredPole` aligns constructs by pole preference (#57) * `biplot3d`: New args `e.sphere.show`, `e.labels.show`, `c.axis.show`. `c.sphere.show`. Construct spheres now hidden @@ -62,34 +62,34 @@ # OpenRepGrid 0.1.13 - * indexDilemma was improved and fixed (thanks to Diego Vitali aka @artoo-git) - * biplot2d does now hide construct points as default setting (cex=0) - * setting a rating value outside the defined scale range now throws an error - * 'ratings' to access and replace grid ratings added - * 'elements' added to get and set element names replaces 'getElementNames' and 'eNames' which have become deprecated. - * 'constructs', 'leftpoles', and 'rightpoles' added to get and set construct poles replace 'getConstructNames' and 'cNames' which have become deprecated. +* indexDilemma was improved and fixed (thanks to Diego Vitali aka @artoo-git) +* biplot2d does now hide construct points as default setting (cex=0) +* setting a rating value outside the defined scale range now throws an error +* 'ratings' to access and replace grid ratings added +* 'elements' added to get and set element names replaces 'getElementNames' and 'eNames' which have become deprecated. +* 'constructs', 'leftpoles', and 'rightpoles' added to get and set construct poles replace 'getConstructNames' and 'cNames' which have become deprecated. # OpenRepGrid 0.1.11 - * saveAsExcel to save grids as Microsoft Excel files - * replace xlsx by openxlsx to import Excel files to get rid of JRE dependency +* saveAsExcel to save grids as Microsoft Excel files +* replace xlsx by openxlsx to import Excel files to get rid of JRE dependency # OpenRepGrid 0.1.10 - * indexDilemma: improved implicative dilemmas (thanks to Alejandro García, (#24, @j4n7) - * changelog file as place for documenting changes removed. All changes now in NEWS +* indexDilemma: improved implicative dilemmas (thanks to Alejandro García, (#24, @j4n7) +* changelog file as place for documenting changes removed. All changes now in NEWS # OpenRepGrid 0.1.9 - * align parameter added to cluster - * importTxt will now erase empty lines - * changed default settings for implicative dilemmas - * dependency on xlsx removed (issue #15) +* align parameter added to cluster +* importTxt will now erase empty lines +* changed default settings for implicative dilemmas +* dependency on xlsx removed (issue #15) # OpenRepGrid 0.1.8 - * importGridstat can now import multigrid files - * bug fix in importTxt: negative values are read in again +* importGridstat can now import multigrid files +* bug fix in importTxt: negative values are read in again # OpenRepGrid 0.1.7 diff --git a/R/import.r b/R/import.r index e2fc6fa..ab23c41 100644 --- a/R/import.r +++ b/R/import.r @@ -34,7 +34,7 @@ convertImportObjectToRepGridObject <- function(import) { # List of 9 # $ elements :List of 3 # $ constructs :List of 4 - # $ preferred :List of 4 + # $ preferredPoles :List of 4 # $ emergentPoles:List of 4 # $ contrastPoles:List of 4 # $ ratings :List of 4 @@ -53,16 +53,16 @@ convertImportObjectToRepGridObject <- function(import) { x <- setScale(x, import$minValue, import$maxValue) # set scale range # preferred poles - if (!is.null(import$preferred)) { - preferred <- unlist(import$preferred) - n_preferred <- length(preferred) - if (length(preferred) != nrow(x)) { + if (!is.null(import$preferredPoles)) { + preferred_poles <- unlist(import$preferredPoles) + n_preferred <- length(preferred_poles) + if (length(preferred_poles) != nrow(x)) { stop(c( "\nNumber of preferred poles (", n_preferred, ") does not match number of constructs (", nrow(x), ")", "\nPlease check section 'PREFERRED' in source file" ), call. = FALSE) } - preferredPoles(x) <- preferred + preferredPoles(x) <- preferred_poles } x } @@ -1260,8 +1260,8 @@ importTxtInternal <- function(file, dir = NULL, min = NULL, max = NULL) { # read preferred poles if (length(line.preferred) > 0 && length(line.preferred.end) > 0) { - l$preferred <- as.list(data[(line.preferred + 1):(line.preferred.end - 1)]) - l$preferred <- lapply(l$preferred, function(x) trimBlanksInString(x[1])) + l$preferredPoles <- as.list(data[(line.preferred + 1):(line.preferred.end - 1)]) + l$preferredPoles <- lapply(l$preferredPoles, function(x) trimBlanksInString(x[1])) } # read ratings and convert to numeric @@ -1338,17 +1338,17 @@ importTxtInternal <- function(file, dir = NULL, min = NULL, max = NULL) { #' for minimum rating value in grid. #' @param max Optional argument (`numeric`, default `NULL`) #' for maximum rating value in grid. -#' @return A single `repgrid` object in case one file and +#' @return A single `repgrid` object in case one file and #' a list of `repgrid` objects in case multiple files are imported. #' -#' @details -#' The `.txt` file has to be in a fixed format. There are *three mandatory blocks* each starting and ending -#' with a predefined tag in uppercase letters. The first block starts with `ELEMENTS` and ends with `END ELEMENTS` and -#' contains one element in each line. The other mandatory blocks contain the constructs and ratings (see below). In the -#' block containing the constructs the left and right pole are separated by a colon (:). To define missing values use -#' `NA` like in the example below. One optional block contains the range of the rating scale used defined by two -#' numbers. The order of the blocks is arbitrary. All text not contained within the blocks is discarded and can thus be -#' used for comments. +#' @details The `.txt` file has to be in a fixed format. There are *three mandatory blocks* each starting and ending +#' with a predefined tag in uppercase letters. The first block starts with `ELEMENTS` and ends with `END ELEMENTS`. +#' It contains one element per line. The other mandatory blocks are `CONSTRUCTS` and `RATINGS` (see below). In the +#' block containing the constructs the left and right pole are separated by a colon (`:`). To define missing values +#' use `NA`. The block `PREFERRED` is *optional*. Each line indicated the preferred construct pole. Allowed values +#' are `left`, `right`, `none` (no pole preferred), and `NA` (unknown). The block `RANGE` is *optional* but +#' recommended. It gives the rating scale range defined by two numbers. The order of the blocks is arbitrary. All +#' text oustide the blocks is discarded and can be used for comments. #' #' The content of a sample `.txt` file is shown below. The package also contains a sample file (see *Examples*). #' @@ -1370,6 +1370,13 @@ importTxtInternal <- function(file, dir = NULL, min = NULL, max = NULL) { #' left pole 4 : right pole 4 #' END CONSTRUCTS #' +#' PREFERRED +#' left +#' left +#' right +#' none +#' END PREFERRED +#' #' RATINGS #' 1 3 2 #' 4 1 1 @@ -1427,43 +1434,57 @@ importTxt <- function(file, dir = NULL, min = NULL, max = NULL) { #' @inheritParams importExcel #' @export #' @keywords internal -importExcelInternal <- function(file, dir = NULL, sheetIndex = 1, +importExcelInternal <- function(file, dir = NULL, sheet = 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 + x <- openxlsx::read.xlsx(file, sheet = sheet, colNames = FALSE) # read .xlxs or .xls file - # remove NA lines when too many rows in Excel + # remove NA lines if 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 + last_col_value <- str_trim(x[1L, ncol(x)]) + last_col_numeric <- last_col_value %>% + str_trim() %>% + str_detect("^[0-9]+$") + last_col_has_preferred_poles <- tolower(last_col_value) %>% str_detect("^preferred.*") + + nc <- nrow(x) - 1L # number of constructs + ne <- ncol(x) - 2L - last_col_has_preferred_poles # number of elements + + elements_col_start <- 2L + elements_col_end <- ncol(x) - 1L - last_col_has_preferred_poles + cols_elements <- elements_col_start:elements_col_end + + rows_ratings <- seq_len(nc) + 1L 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, cols_elements]))) # 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])) + l$emergentPoles <- as.list(as.character(x[rows_ratings, 1L])) + l$contrastPoles <- as.list(as.character(x[rows_ratings, ne + 2L])) + if (last_col_has_preferred_poles) { + l$preferredPoles <- as.list(as.character(x[rows_ratings, ncol(x)])) + } # read ratings and convert to numeric - ratings <- x[-1, c(-1, -(ne + 2))] + ratings <- x[rows_ratings, cols_elements] 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 + l$ratings <- split(ratings, 1L:nrow(ratings)) # convert df to list row-wise # read range info if available - rmin <- as.numeric(as.vector(x[1, 1])) - rmax <- as.numeric(as.vector(x[1, ne + 2])) + rmin <- as.numeric(as.vector(x[1L, 1L])) + rmax <- as.numeric(as.vector(x[1L, ne + 2L])) # if not availabe infer range data and issue warning - if (identical(rmin, numeric(0)) | identical(rmax, numeric(0))) { + 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", @@ -1518,7 +1539,7 @@ importExcelInternal <- function(file, dir = NULL, sheetIndex = 1, #' 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 sheet Name or index of Excel sheet containing the grid. #' @param min Optional argument (`numeric`, default `NULL`) #' for minimum rating value in grid. #' @param max Optional argument (`numeric`, default `NULL`) @@ -1547,9 +1568,9 @@ importExcelInternal <- function(file, dir = NULL, sheetIndex = 1, #' rg <- importExcel(files) #' } #' -importExcel <- function(file, dir = NULL, sheetIndex = 1, min = NULL, max = NULL) { +importExcel <- function(file, dir = NULL, sheet = 1, min = NULL, max = NULL) { imps <- lapply(as.list(file), importExcelInternal, # make import objects for each .txt file - dir = dir, sheet = sheetIndex, + dir = dir, sheet = sheet, min = min, max = max ) rgs <- lapply(imps, convertImportObjectToRepGridObject) # make repgrid object from import object diff --git a/inst/extdata/grid_01.txt b/inst/extdata/grid_01.txt index c0f0d03..6c07944 100644 --- a/inst/extdata/grid_01.txt +++ b/inst/extdata/grid_01.txt @@ -18,6 +18,15 @@ left pole 3 : right pole 3 left pole 4 : right pole 4 END CONSTRUCTS +Note: optional block indicating prefered pole (left, right, none, NA) + +PREFERRED +left +left +right +none +END PREFERRED + Note: columns represent elements, rows constructs RATINGS diff --git a/inst/extdata/grid_01.xlsx b/inst/extdata/grid_01.xlsx index 866b074ba0a8f3ec6ac2ab10c09173d4ff09dac5..5e1f4ab9846ec24d443b26c101b28542eb658f76 100644 GIT binary patch literal 9346 zcmeHNgF(~7t^o#+P#UC58VQk-R63-tRB?{mwkI&olF!cg>!)*Sp?*);b!>Komj%8UP&t0MG&~cXRB`kN|*06aat# zfR1b|?dsxb zmTDx>`QRY~_$-=YoxREZWmd+y4i2}uQJ1(Jty=eD zf(JWw&Bz5f`v!IxJBUe>+>H$P@(9T#xJk{;<7~448PLWaEnb;5Nu>%hdk~RW&_>SU zfF9mTfAhUEqY|M(Sl6nW-ZGxxaOpJe#w5XvqXY9(v!e}mMU)u2r%Oa$WB{XM51M#pEv%52xxy3Mus@EiptZIOP^t2g)s#jbml^dZI6nfN{Fcn}|R ztZ~u853)CBH_nv^rVW{z2WU9O)DcyJUB>-;#X$usBm3PnA1@i#2q=12$gNv)6B4b} zNa!GJt3?C3GU`GCEFl4}2Zx#jJJsP<6n-wnlXo^zWY2C1Pw}=}jyk1qhdOB){3GD2 zgWDoccP2g=hwdJvZ3lvH&;WqjTOdH=Z?vq}<)S}E#F`3%b(jcRn!DRLdvJ3682?Mh z|6mUO<*!#HsjByI-3#ASxQZD3KKn5dS4!DiQlXVrCm=|138y};fPwsD$9)Q19kNiM zd|+F^)iCVi!?>@5w5RL56*2gPBJ>U3mEq|Z(8qUJnB3FkpcQMqcwVz7v!|KzO1=-g z+7ejGn@V0O53SJ4O&`cqANU-iqaPk0?2Tc zaI`ciw^ktvwA|~G7i7BznKvSaC*B6vq9j;iv2v0|^?Gy)%OaCcL|jZC3L6irEb&jt zRy+u(Ueagjd0;hX$}|TM4P#B`W&V?8iiR& zp#V|7E~qK1=G4NXlha>!WsVD4M!G90SOuo4ewM?No{2>#LQ>%d=ayg0=wG+ zO!XaYZIv{H`#RD|uf@~Y4To|Ax9sWW#ZcLtbZAM+P;S3=mA`O6V0~S?9d#8oq*2Rx z$Bb-QW;RDBYIz1vv|&q+No9VmaZwmxJqpgty?yNw=f>4F`Rwjv2;8%M)rU9Y}D}#aa@L zkMe}Tc~1n@_5IO%Ai5>Ik}5mR|>$h?^CiV*tf@ZO#LAG2%!Ov$87)c`vis@vI zo2SBg9mlvHgB?94D2EZLZ=`NB=psyer!u6jv61Elv+bwbW@*?d+RG4M>d7P0yNVC7 zd;ybRW@uT@x@1q$58qwcs``#ObroFP`$SQ$OjX7w>KE=w6EP@H9mt&I@hLyERd;XA zQ|fYiyXOJdr~m*772=J!;*ZSdVQ*vO>B0H)#Qh@$ zW~ad7v$$}>_gGIT*;ejYC8;Jqu-1jMd{t^I@p{_CZ;P(ytOD68EZbW~LXILVjV1~v z?H~O67?-&St}nSYukyOjaI6Lhj*jV#(?j$u zY2W$Nm;^{T63CAHc~4pQGS_xfRFHnjOFyBIkB<&qq$^mjp%iQK&Y9(#OmX!t{Y!Mk zc%pv!Ko$| z8{XZ;zzRc-#`)5RMS<%_+}$Fs;b-7ukHBrmOxC5fVwUwhg>AcbpHJB}vo(;sml)VL z!%ULau6dGZ5_oEg(=RjYVW0bmJ^Lb$;h0!jgL$X>C`PZ3zfl-pd9#KvVN^-3E$+_F zLF5BH7zn6xD{hJoHS!q(goFq!U-$G0#n^5zP#tYP%J8d?;LPK<>BK#5xUL;kA75qU z=lx8|sER%1NZ9+FWY#ZZK4EsM8*{yA3g4$h>uNjisLK#r5L|8(TyYQwYTEMnwQYry6C z)6)j1iJjNYV;|A1m$@J1?M??wDdWdE1FxsgeV(*AXZJN0)tXXQp0v?q~jeT3hHB80xIu?UqF#O>^jL5Y!y{7Nlr?kOy)w zKPUkinjaK`&O2kf3Wn0jDj3MP_a{l(;e*3ds$yr7lAA(i43mUelWLiu zagH=ssrC3zD0RHJS;yd*878?VXE7faRLs4Qly~kPF#@wt88}kzEmA3>@y95Rg;k|& zjxqp8wiw>fR4^QAJr{OLs@22_L#&YX&;RLAp1)WW zCPPo0D!9r}#z4hUaqzoV5)VC8=-fk{Zj$4}WvWbd zbLMGz`C|q<$dLI36)OawsU@)~s7eD|!br!KcCR8UQCNG(f^S42N2s)j2Fe&!u3)0N zPBtrHFT=W)VMS3eWRR~GCulj=6gp{~7S`6qNi7QBQ2#nf3_L?u>5ZpJE_NUdvu z!&Sglc53cKVW|vuvi%y#*>TQ!5%Q*}@-A|_meJ-F7mg%vzmwQ|_zR(#RNtOW49ddn zxHNE83oQ2Ds}rG+>y5T&K0trY95YJTtISv4V6nkQT0v5=ph5Og6R<82G*k(N(RFp~W!^!$_zPkS4P4d>7Cr&{b7e)L!r#0~7oyrkw0a0T9-NMznd zL58co;7^`dK8995tE4lgQe^nl(UEE`fswDcIJ%_ot59_{9kA!9|1RLDa&t3HsZWMa zVUg4L?kimuu->Q8&1uiWbwOGs=~N_Q5G4a^S(3o(j@wf*HBU)pCAYvLHH$<-qYwA* z++pdn(cqL-W%Uyvu0e@Q0E-VYEYW^UqNZptY750TNKM30Vz`8g*)cO}OM`_>38+2% zD(b+P%;^H*yjWfa&JFhDVMe8R>6=7nG?HSOO<7Z}!n71A{luY#HsV8F+uwkK4*bwI zySI(5mg4W*ZKWFo>mJ&O!MGsm!q@s+o9$j+`va9`TRU8x#)&=N-upRg3-&XZ z`$U`jZIoA=x*Z?x9uVoc>9KoF^uJ10l=cT^V%~6Ih|8Tp%Y$7tNwBiMfZ0ChPhDD8 zhP{AZ`&7iX+AJC?L2tHWYgd1ojy%y3<@xS}xH zFVB0^C`Chvt}EW#lj&uHl@S2bOCq?AzHp!gJ&0Pb)2fNK(*5PCT~sqMu-!BO%eswu zQ>zwzD<=P5P`cFqt3*wp35i+zP?|249Y?y@F4-!7|5KFIL+FN0oU9#uy7ROk1kKV6 zTEe?om;WNe+fvd&rj;`m)vL|Alu&7u@4R~u*I|G(#QDG@uP!5Ed z1TaZ=SsA^YhT-0|m!-lBQ1Z3tZ>*Zp=vPpCwb|agCrQjr>#7IFy7z|niSTQaM5tV9 zH2nO5rujG-anLr^<4Z>KR9Y>^hR8`j9I3NGk7^Q-#++uRq3+qd_zbc%;b7_n_gN7- zPw&G5>b%8oyW_EFy8%tOewMy8Q~VO6Sw*pDhwPw7VsFkUN-Dtyc%f4IHD90VCh)L5 z9oIVT%g?b#Yq4eb(*J#{q*zFBd@WFoeey+4sIvRG!{F2or6Uxa=Gc1Z^R=E zMxh$n`7%4s?Icoq`hs1j5+YkG%dG(^0AIN2^O-Ce5Rd~y;3!7T5z?=pQ?^1@d3n6N zlUEnn!%u2k6hMiS{qk~qrquP7$#c~;*aeXZqnn382@hTTrBClSiS{dswT@AFIqhA? zrq69G&M7mw?iJC$z1rLaHIp-3?>-WsWu6JOjt?aZV0Suh0k@ItQ@Dy~v763|XN>Zj zG%oK9^wh-FHr8IocS};16isdAVGxs@>JlKotFbCdy{(F|_2)n}DZC9Llpi3u7nnt8 zKQK}6DfYVbGzVTeUkXEhp~aH+VmOPgm7b?P$q&@ML%>(^hoXf9N`tLyg_U-6W#M;zR$fIMf-_N?Cx)Fw@i+%wY42!IL4xv1eqV7_JKNKtf!Vnh?8nz{dkXk*D+d-%`{!2+yf+-=80_2geyPsmWwq8h7x0>#n~w>8 zO~?nIe3DolU)?c%CSDY|pznDsWM;(KthZZpLB8Cwma_Jyjr%;u13ow1@l&pTuRHRS zNtK`=)Jz!B9l-iumGJQNb++;NaW~PcYwQH$A`GD35l3%pZRZ_JvS{U1#d_v)Z>r18 z##l|}F?UUp5as2b$RQ)t;RA%-**CI?ep_TkXlq*2a}quNROf@r5Xq$-m7LD!G7EQt z4NmV;o}LnZ8KN*&MJvBNzIKJ>ju=OeRnNAf8JeKP$FYt5I+!0SkJv$lV%nh8DlHcF z$l%iDrpHCh%#KeL+ywUDm9nBIH%S{rUa3o8Qf`#``JS7pZW`Nb_3g2b&B})a_%t2ZLpY|KK7>yT z%%gard>?s?#j<6Jl8WV;7ZnLM0FjG?Y`aAlOxmp|pj~f9&Fi4ku+Y8%7yM7rtZ~Oo zG0+!J;NveC@#2Ju@=(TjO_8snn%cdK=4JN(jl*jnBG+14- z^fasmWQ~g!fG92}**(H=!ugaAY!og?SMJa_cVc?U{I}zmQCNiGPoz-g!M+ShR?W}b zCb-QSDNTtdXfN_#IS({FIwXw(I8J8EY#F{Mhglj6Q6XH0VU$EE;62bs^0J@Wq00-A z4?4c_z*wiHde3;<>%Dtk8d2AAH}ZMnp5^D*a^D2BU2&P4z7FO&O5?F}SCh7*;?P$U zY&LqMx4ne6_+DjjxYo@jDU>W-8IBQGslkxZ zjvFST(=94`F{J*lbiqj31M(p5x1tc;Gr~XUV*kk9##-Cc-ND7~Cu{uv+BOk=yp%ST z&tOV(fLbM|2liDM6P(8m=@^LYONkG+8GEnk2ahU0+S-Z6L5Ch1u+}o`BF$g8bidMj z%Q@~XuiI-~T{}iU^A$5+SfEirH@0+;qu(fwnLWX1z$dm9TGrd)j z;62m;&i&9%YLo!NGsV^76y(zC=Pcx5on zTNXpO&M!$*xrdAJ*$V2d^w856g&rO$4Zzg3P+(Woy0OA;Lk$y_VjZkQ0MclbiSFAh zv=t!qJ;@oWp?i!vms&rD7sDJa5o470B&*=V3I4d|=EDz3`t{)ylwGf6q5i3NlcN{A zYb&t~%tK<36BY@(^qR%Vg>5!if#8Ro%BGMKwM7P4p?tp)>krGXBOBPz{HcrA)F}7HcM*$+H zynSmAf{e>^ev{4$j%#-@-eYrXFY@)|myPC&k+0%#E0kM;vp=aUwi5PuGttgCa7Wvo zPxWLtWFYHZ_sr_u`U|!%cfyw28JlF}yx)D9a90Ug8h2i8CM2iX=~7ydbjKA0o?2Of zd)pb+J_|!8xFJ_>y=_&DK9yGUgiQmd=S?%txe`OCyUZ*KhvKxy>a7xvbvS7c#H+Tn zcY+^v=whJTgl(3>7uo@(~HB*NN|y+liYU zXq>ArGR|8kJFZ5~+TLHe>-n)BYO6UK`3G1Zk^dRRNXYC6W%~E0J^oy^KhOX2?1zT( z-wph|Fa0O*$2lEAjlXoMe+T~FtNR6ghv?q@*17u~{PzyYFDL*IdiN*z|LK?fZs+&1 z`7cWinEyA4e-zPwxAJ=><(HLhynn5${BGd)P4+JXIEZ3C!WX}`+`mJA-*EhbiXoQ# z2lV&t$L|*YuBN~606+l+0PqiO{T=@IO!!wg6ZK!ic~gClvQ zI)K4Rh-npwc-@vv0BtQS0P2%TJN^IM6-j-NHf~%HjA6Gy5z|;p8)P=pT?4uu6dc7A z1+p-_zwr4WJ2Y4pbQ90%0sY`>_ig3P5i3L85mH1_TQH9@3N2#h4QHps=-y5HFs)5MrgwIn#xDtlG)9aOLgC8ph>v(aP`h+Kk{SBpfwHfiP~brUAcCETKc8tHLn8P17`LZk9^y7qUX4tRU^g`d5WVH-no zLTn@>@;!3e^;&;V<1)VeF)w81IxKq=0y!8#r+8c=CekgT4j0AMZ$ADmitm5?@jwB% z08HJio!q&=vWEZB0sre|hJU03xL%0NzYH-Cz34&Xkw;@^M8LDW9mxVsJIxSG8=GCiiiLJ23)8=IB|Ys_U{Tb_HL_cJ2z&yDZ_4{ryzakaE&qU zCG7d%!&iIqevzWrH>;{1IdGF_ec`MlGKq^X z6XDip@gb$J3gfe#-fkEYO-M-zSho-e!>b9q=kQFv|3e4evLbE7?x+Ik%|4!b;@;2W zypZ)HqA@5+fBMQiM}CND$c_7!>0c!bGYZ|0sXsU`zqe_hMumUa&a(EQOg$v^+Epr!_e?NR>$G2XE zhc9Fp!x9867O7x>H=a2!)f{0}cFRl9O1A_Cl~o_2q(W*JeM%Z(@`lEp-f6F{v>tH} zNNYkGDExsDqe71yWr{%hA=L}Ni5Z!~EBdrmtcXi;rl8SL;(c9Wa$RIg8j9uCo9TxZ z#TySIunuPd%r-hx?nn;-C}{Wg@YWk$eN$ltw~ou=hq~oin<|Wp#^ty31Dp;&+P?xDh|XZ@lw{w1m1@|NEA#7#UJ)rv{?#zzP=T5Gw}5 z>fV^!FsUe)kND8-Y-S`=A=J&nxV9#ryb*gI;7jEb@8+%*xQjICEvFl4bA=%{EHN9x zwl}#s%C8tOZ?HROS3Ha^Ix}9tjct-uJui(a9u>JyI1^z;(q*zK<(ku}*S*vy)G5Pm ze23#2>Kx)Ay1qH`EhS1J%KC9ma$$evX&6(1p2F9yqxUMBW@}Qnuqnr477zVc5QRPq zPI|T{u`|U#H=H&nuE|TA7ozW^8d9qq6CYKLzXJ?j-<9TD2u4k~c|}j?)#JA}e7PFp z2e2n@ zoR&A#&Cvo1b^Q0|er&=3q@5Z!)D(HExiw#9+@PyTOWVC{JSVF}pA3jZq_nZLb;lXh zTg_y1ZQs(i^iA*Q&1-b8<{2Wj5ikP@>ON!>I{8*)Gle4n~~k>>M(b zcj&q{h8Q(nmXyk5iF$j(2AXJ}tS(B3gKscFfLK{(zshxo&X`J-L4=}w$~-CIBnP@D z)QF?QbZ@Nb+6Got!9jEb-_151U}jW5bhx(fxHEva(g^!QpxdCVsyn`aw(AQE``So< z4x0|^IMc<7Gr(U@eBckod~=Pvowc=xJJ;{i^e^#v%j@mDgRj9>@Z^l{mv}BP{Qko8 zO-sKaX{-32wBgFaI%h<@UL#2tL%0YvE9(M+T?M{vD(0N?U_)-j)Y`X{peFI6pS+fq zk1R!qLis`Ke60B` z`gr32PwK-=JJ*6VM&o$o-ps{FK^s3H#8ey)cL=0B;eblqtL6+FeY4a>jh^$#HGklP zVyo;y8@2~1xe>{xV+8P58n3M?KZE=|e>FBrDhU?Ia z)6_WIa~p*!h^wt9pwKlbW64>@7t$CdFC!H;p%^)oHjgFjKSJ~*w%k846&d%meSc$m zOw#0$-n^}XJS2+#PR4kGolqlj(M@eDix(T*Wen!@5wb99aMYOpJ@aOIq`v9Z!24rg zN}wQ@mf}E1{3gMhhtn&-Py1Y$CPuIK$^Kd-m_GuGm7BS@J;e6^(h`pUCuYA-$CoeS z1V8w>xY@%iCvISC50Bqwz+Vx$3jfu_9r#k7j0XTP{g`NfCitg!9!?8;$iKUl-qIa` zgm7a9#JVwYVCC59AilW$v_e2c!iydqV-JWbUltAE)#NEx=LZ^_m(!g1o5t8@ zGQgAU%cY4s{dqn{Kd@5{qhOrTI-xRfwIIP z@oQQcixhY%N%JjtM^!n|M<2p7buL_*C69-aXoTpF;!TSxtDe|LqH3r5&-rc>e$E|Y z6CVv$w?(ZTu9jX}-0lGPu_0OHdf*mc$EkqOIJCV_(P`9jHdvJGeU`NSF|r!JY`b8Y zrZl2ea52lt=nclFFtz!B)1B}qRPw%bEq2MggMy4FJ*SBtpgD`mO3%m2Sb@%cvJ}_> zVFo0{m|7^TNb(lB_E;?`x6a~W?$&F5GgaL~@z8I9;g@c zmp3Q9cf-e^?9DP=_zH!aKK_2!mcbYx&fZ{WCNp)lDD$5ERo|=t1+?bFPzz2O-K+e` z9iy4)c4CHxT_g{GaWcf>AZ)LVWUi@3B~63XkT^? z={C)iW0#Q+*EHfy^V`!cjO6Rat0MxE=ihV0UmhD9vuAIHd#noy0KodgV;;Wnz1Y9+s)Bockk{0} za8u;!A+z`yW)kz7Vk?$R$X&%(7MPS;oJ8D-*+tt3qUj{oBZ{Bf$b*EaRuT8?t5KT! zaO=G(Al_JVqv#S2f}UTd9AO8+8p^L@U;8kLJbM|LLmX?*zq`zAEe&v~ZtqT7L88$h zFIaY6wS8{}IyCdWZJ(x)6|!X6uR56!IQE*Luf9FmrE1ZXIwj(5(V?o3$ftZ%XAc96 zjTrqI=rLQb175%$>(+~VJ_U6NrbvGD@u3(oXVT)IE@?)P zCG-^XlsnKiSmCBV;>lS5{Xou~vNKp|}@aH^xhobDZKaHs%uV87i ztKtt9+yvzrd|Bl=Kv<^DQcC@xY8gJ2$Y*tuGev21(#w&kwH0(YUN?f!(2Ab0q!)STqNp)lZh{ zU^5uYG6c4$gE-yqTw!{COM3=12ld|6upr?zV^5?*6Ot;!Q3<_KGE)`C5VI&kx7`q= z!&jLLxz}FeC=!&+AFh}o==ch-VQJAivdmEtN}zuHG^Y9NZrc%}BI|r!a(({*9e4kl zV2KU&J2q9Up{Q4cPAZm?N1--Koh*88^X7Ft`mtR{)65x+!aC2mAFe5mSdS+d?8Mmb zMu{beq>nt)BxLs+N?9+u#-aH#1auu4qZ>no_$%Q-Qy@r3A$ znA*hT&O6Qkg<8pdIYpk7QVs^HVLQI~SyB7X($1L=yp!e{g?RFsAknIg$lSUQKS=2_ zvS1iJC%i6r-TVgMmDQ#2>UXU{%c4C8Sn^RKfRbgYW1WiGjbHQ~C~5^O%)&n^p>vE&bNoi&`jqwCqs zqWR@&Oz<05j#c3qS&gSL%=V`%jM+tX!D6Eyuhq*=3E-<-Em_bcswZtlx66xtI{LY~ zQoh|RHG{0lt=(2=bJp7**?KKR@2+l+zbP7v$(TZbxX>bT^4tnpQs9Ro6VY67}MPVq4 zQ)roIZiUU{qw-aXl?)}K_|O_9NAp=>r^y|V=|rk74if8jfz)ToPl+n*yUoTNZoAyk z;U^FYS{@F$5d-zLJYIhLzuQ|wwiNqSe^`$fh`*4 z@)@m09R+OYdR>#*`B8~#Hid|xh3t~u5c24jOqVIo-FHd*#ax5NtAnp@09MdHn9;&A zOw31cC~oyrCS_Gju?zSM*BRx=?I$LhBT+Oq1aKko-#T8 z4~X&psiainN)N9jjQifAN`BtJD$XL_u~CiR=2IKQ6@^)XOzD$V@lv{T$4pP-b|e)@ zGhGYu4IxXs?NtLZ9QGGvqBF?o!37B~40lYc{f|vY^2fAF30?U3y+vuF+ZXIKJEu8z zazH$GVZjF4UN1w&T|;%3Fs}JkVxV0~;&>%SfRX zW}Z}ZFYAe*t{Kq?rQ`P>m5#1=1BdJ^*K6lWs^pbs)4>N}&G>#_7IS?maVQ?n+tnJ& z+Ru_)VZ!sOMcrCd^8&;X;vjDCE1^1fZ@%-*hq28k617UW0Nn{Od^ixL=FwXcyd_t! z%t0SBqvf7?PZ8tgTac0JOXsYjPz0mEbKnso>w#64+4j@k9l4xC~;a^WwRQV8n12xvkMY*#D@pVgFZ+?f14mSzYQpPT`sOGBE%^{3EwJSO5D}SNnID;@DS) z?hh2;{h3PXkK$7F2bx7XO{}>PuY+u}GOf_UU}c-#_eB#}_dlr>IL=*f*;_Co4apuk z$XRavLX**uFfmYY6OXP5EM8&=|1ym4_AY4CUzL@ZIyMv2V;!}sW6?tHE+mVcjvHuk z8q0`L9XPDSg>v{hllz~rFZba+7?{?g^GmG>cv)-durJvRJ=o>2i&inxlE!Kmh~@MT z!beT?maY&&ZWIR{sEz6KcgZ=`PRSfJ24H}yXT2RdV`tE*NSgFhRpep=_{I~Qk^_PQ z@-zj;p$+RN@x5kNCuuR|$FNMz+NObGtfr=MatLL;BSgHO41!Q^2%)JLf#B8qL);y3 zUK5Qw*(vwq3g6=noy^C~6I2Qx&LWgq8_ZZJ5KAHTmiS~Y@rfqA2@5Ne_gSd$RtkxX zU6B%=@QOxl-qdq!q-b3Je1R)5%rojeMiCg{2~PdEZHz#goFr1lr}>e+kC+!<^0)Vy zSUvPU8WFMDlbOx}M++!>7s{m4T<^3*GY^c`GnB;hR_VcQlM~M33q9myZbP$lNK<>z zox9`7J&2=@v88n+di zaTKw%#46@O21a-luMOIiGI86>Bw8=Kn;*w2hH%>+v0!t-@Td2nNAKSbzn576N2hhf z&~9R;l5*}bw@K%a?$hT+K4r|0WTT@PWLXq2S>v8Gm&SXk%-@h79#+mQJH&GF-y~dgg13X+HZHGcSh{^f+G)YXjSZSTnRZ zv1^6YP`zD@V1s+aToF&xShHQ}5wY~p6fm3X{@#bLt!0(RC)Y$!bM}}Qfi^%Ie_cyT z{_=iXG%`jrH0ucA7!RSTh1(0u0>XhqQJ!h)p{M!dJ8=fQp}e}nMqrQUK7;;i@@JCr z@k72qiP-zJal-{@p8n%i5Yq?*P$a2ldodnJPpBx|lbyJY*aGhA5j{mLiJDYQ^G}t` zZG=!5{okYN9vH$i2@y6|4}VJ3`nz$E%WS zzWO|jOOAKVkv%XV^VGSsQsSe_^lF_zNgzykN`hiFe!xJ$_#R=l{pQ5b+k)F6hSw~| zZczG`o#}go2_v=~=limc>w6P8hj-s|EIYf_xg@Brgn&p1uZ>)OjtX9MgI@>$>hHgR z%THBZ`F@&4TMPNe0jM8{mzNk(;0^g77cTsV5MDh0PZ9J|kYBVeo|-vNtK=uhALaH- zkuIl$et`}fd};c5=mIQzDb6oO7msV4XVi8c=jY*#zk$1WXyH5@27KT8lh&^z442|v z{+UP@KC=uJ@T2Aa4-l?iKoCXyj_|Wb{ttj~F93~S0Q#R&xctj5I?xUM2d_W6(3jHs z<-m)L;`0_qhY$8&ZR1PPE@uV2@R9i#KhZAq5&u?U7n_mi3Cdw!4*4sE`v08^(^%g} z_@6HMWy*`)u=7lz*ynIA>5csZt72ZT>Iu$w;B#%Be*lGl0V)+9i{S453H3ie`f`sG zTmTe=TL2FDr@jRIT*Rdmf0^-Ouj9NKr!PnR(+GcbKK^Eui#74{qYweV^S-1){x^^p zi?-(>dkB9(o-5)04c5g{-FYlZ__pEF!ri5ampcmkf}_x=z9XL7g#4|KF79E@)64%a buwT>h5?Ew-SpT*SA_jQF1F{^$x3~WXPsNV@ diff --git a/man/importExcel.Rd b/man/importExcel.Rd index 920ae50..8f1a552 100644 --- a/man/importExcel.Rd +++ b/man/importExcel.Rd @@ -4,7 +4,7 @@ \alias{importExcel} \title{Import grid data from an Excel file.} \usage{ -importExcel(file, dir = NULL, sheetIndex = 1, min = NULL, max = NULL) +importExcel(file, dir = NULL, sheet = 1, min = NULL, max = NULL) } \arguments{ \item{file}{A vector of filenames including the full path if file is not in current working @@ -13,7 +13,7 @@ directory. The file suffix has to be \code{.xlsx} (used since Excel 2007).} \item{dir}{Alternative way to supply the directory where the file is located (default \code{NULL}).} -\item{sheetIndex}{The number of the Excel sheet that contains the grid data.} +\item{sheet}{Name or index of Excel sheet containing the grid.} \item{min}{Optional argument (\code{numeric}, default \code{NULL}) for minimum rating value in grid.} diff --git a/man/importExcelInternal.Rd b/man/importExcelInternal.Rd index 4710e51..0c74e43 100644 --- a/man/importExcelInternal.Rd +++ b/man/importExcelInternal.Rd @@ -4,7 +4,7 @@ \alias{importExcelInternal} \title{workhorse function (parser) for importExcel.} \usage{ -importExcelInternal(file, dir = NULL, sheetIndex = 1, min = NULL, max = NULL) +importExcelInternal(file, dir = NULL, sheet = 1, min = NULL, max = NULL) } \arguments{ \item{file}{A vector of filenames including the full path if file is not in current working @@ -13,7 +13,7 @@ directory. The file suffix has to be \code{.xlsx} (used since Excel 2007).} \item{dir}{Alternative way to supply the directory where the file is located (default \code{NULL}).} -\item{sheetIndex}{The number of the Excel sheet that contains the grid data.} +\item{sheet}{Name or index of Excel sheet containing the grid.} \item{min}{Optional argument (\code{numeric}, default \code{NULL}) for minimum rating value in grid.} diff --git a/man/importTxt.Rd b/man/importTxt.Rd index e43f79d..2dc87bc 100644 --- a/man/importTxt.Rd +++ b/man/importTxt.Rd @@ -21,8 +21,9 @@ for minimum rating value in grid.} for maximum rating value in grid.} } \value{ -A single \code{repgrid} object in case one file and -a list of \code{repgrid} objects in case multiple files are imported. +\if{html}{\out{
}}\preformatted{ A single `repgrid` object in case one file and + a list of `repgrid` objects in case multiple files are imported. +}\if{html}{\out{
}} } \description{ You can define a grid using a standard text editor and saving it as a \code{.txt} file. @@ -31,12 +32,13 @@ consider using the Excel format instead, as it has a more intuitive format (see } \details{ The \code{.txt} file has to be in a fixed format. There are \emph{three mandatory blocks} each starting and ending -with a predefined tag in uppercase letters. The first block starts with \code{ELEMENTS} and ends with \verb{END ELEMENTS} and -contains one element in each line. The other mandatory blocks contain the constructs and ratings (see below). In the -block containing the constructs the left and right pole are separated by a colon (:). To define missing values use -\code{NA} like in the example below. One optional block contains the range of the rating scale used defined by two -numbers. The order of the blocks is arbitrary. All text not contained within the blocks is discarded and can thus be -used for comments. +with a predefined tag in uppercase letters. The first block starts with \code{ELEMENTS} and ends with \verb{END ELEMENTS}. +It contains one element per line. The other mandatory blocks are \code{CONSTRUCTS} and \code{RATINGS} (see below). In the +block containing the constructs the left and right pole are separated by a colon (\code{:}). To define missing values +use \code{NA}. The block \code{PREFERRED} is \emph{optional}. Each line indicated the preferred construct pole. Allowed values +are \code{left}, \code{right}, \code{none} (no pole preferred), and \code{NA} (unknown). The block \code{RANGE} is \emph{optional} but +recommended. It gives the rating scale range defined by two numbers. The order of the blocks is arbitrary. All +text oustide the blocks is discarded and can be used for comments. The content of a sample \code{.txt} file is shown below. The package also contains a sample file (see \emph{Examples}). @@ -57,6 +59,13 @@ left pole 3 : right pole 3 left pole 4 : right pole 4 END CONSTRUCTS +PREFERRED +left +left +right +none +END PREFERRED + RATINGS 1 3 2 4 1 1 diff --git a/tests/testthat/test-import.R b/tests/testthat/test-import.R index 12040df..64a4b04 100644 --- a/tests/testthat/test-import.R +++ b/tests/testthat/test-import.R @@ -1,3 +1,5 @@ +# TEXTFILE -------------------------------------------- + test_that("importTxt - PREFERRED", { path <- test_path("testdata/grid_no_preferred.txt") x <- importTxt(path) @@ -24,3 +26,25 @@ test_that("importTxt - RATINGS", { r_same <- ratings(x) == cbind(1:4, c(2:4, 1), c(3:4, 1:2)) expect_true(all(r_same)) }) + + + +# EXCEL -------------------------------------------- + +test_that("importExcel - PREFERRED", { + path <- test_path("testdata/grids.xlsx") + + x <- importExcel(path, sheet = "no preferred") + x_pref <- importExcel(path, sheet = "with preferred") + + expect_equal(preferredPoles(x), rep(NA_character_, 10)) + expect_equal(preferredPoles(x_pref), c("left", "right", "none", NA, "left", "left", "left", "right", NA, NA)) + + preferredPoles(x) <- preferredPoles(x_pref) + expect_identical(x, x_pref) + + expect_error( + regexp = "'arg' should be one of .{1}left.{1}, .{1}right.{1}, .{1}none.{1}, .{1}both.{1}, .{1}NA.{1}", + importExcel(path, sheet = "preferred incorrect 1") + ) +}) diff --git a/tests/testthat/test_bertin.R b/tests/testthat/test_bertin.R index 3817c00..9b2da79 100644 --- a/tests/testthat/test_bertin.R +++ b/tests/testthat/test_bertin.R @@ -1,11 +1,11 @@ library(vdiffr) test_that("bertin works", { - expect_doppelganger("bertin", bertin(feixas2004)) + . <- expect_doppelganger("bertin", bertin(feixas2004)) create_bertinCluster <- function() { set.seed(0) - suppressMessages(h <- bertinCluster(feixas2004)) # ward -> ward.D message + h <- bertinCluster(feixas2004) } - expect_doppelganger("bertinCluster", create_bertinCluster) + . <- expect_doppelganger("bertinCluster", create_bertinCluster) }) diff --git a/tests/testthat/testdata/grids.xlsx b/tests/testthat/testdata/grids.xlsx new file mode 100644 index 0000000000000000000000000000000000000000..94a40e0f620885319d22c5bd023df12b4c1601cb GIT binary patch literal 12616 zcmeHtbx>Se_BFxXU4lC_8eD=q0fM^*cXw|{(BK+^LvXj?)<|%7X)M751n2AIz4^U2 znVJ8;s+mhw-=g}ib@fkK4V zlW=r!vv6=TQulVUa5VsU+1pX%!9p{9go1`V|G(?Mcm+n2)@^#&aR*Kid?ON;Cnd?E zIm!(W$9L#Pg1l?yY}@I*RkOuCvQt^%F}jr?N*3QpZ1p8r}rEIX+7?n}>Hnemiwz5>x( zb(V_T%>+j>K8>Om+O~08Vcn9&5`y2`x*Lzfb#dxL?5HICQqW8yld;GFqwCq3-yf*R zk}5yBAq^)-0R_4y5#o_;gBA!sNUzD-d#?E2Pn+Ue@8=K|Jap3d(F|_nIO#uO$rOCY zpb~zyoh$h(^fm>K8sHZ0wD3yQm&;|{5>I;b3DMB0&1>&Jb zE*5sKY=EDi|MSfMVt4%8)XNi;UiGr00#9V`BS1f9SK~3o6+Fdc+bGoog5*{(8e;Nk zNLD-PNio%lLt$hB+XL>0msf>izJe&Pwz$iquyF;c8$Bz4skhGV2uyS?Dbmj6n|)Xw zvzN11=`!-(3?A)qOl8d_xe7z;)Y8*uk~Ns)04-u9oI+9{zHoZ5?tqfcn(1}rvsv-i zM-{;8Cf<)<6UQ?H=TnLf&_pBo6%VJ<@j$MomW!2sAUn#-8)A*uR{Yl0rXO4csJxBL z?Yh28W_IE{_^~Qyfz+tDv9CGDWd>R+8? z$2Sws6b1^a6cW`iAS>f#$L8tiVr%N?X!|pS6=>Q!E(zd11{B_r=lQ)Ni@>B{%0`S| zl|Rztm|MFm<&3pv!4|B`7JqTndBTT@Y?0AS1}zxCAD81g=1K|>wHxm7ek1S72n2MT z8bly5aREL6kLSI=UK+@dP;sisb_0)5rjH}aI-gqg6&iG9TU?-C?&oHbyzWP|&ZtY+ zN73PU#;i~(Z)#lfA-)oqI(>|Y%OV(hJx)cg*{KP!MgTzqkeXHdw!nQTY%zpE6BFjb zeT;cEFZqJBIiW@_ZJ12uL86&RXJhm=Bh!A7B;e zWsb zqjvk!>w1o}I#mHuKO6thI}j-NB=Uah%_pbq5G$@P%_fTzN8Kuwi<4oW$_jSj%1uR4 z{Rj+>cKnKsp<2lCfQ(|OBnl=kZ3MptGL^ymW+`CSaG9;!R1(gh%Ob7>r%a@=T##|J zye>1{&#NN7hlwfC7~B6uBmNPALC64WSS3AwT;&ayroXz71bo(vlC6trMnp7W2zr>j za@kg(Y_bXoBkbg&Pqlvl38Rx_e+B7Dw9Cegj|&Xrjra#jF^W(-tt znN27RC%(%8B<^+w#m@m#nO+ava(VUBgG1cc&&Em^iV|k%)_2y#F;+3L{cGJ6c#e>- zwlgfNxI6CJ;w zwlQbGS*Q(9(9-T}Ke5S0{*NQ?9&m4v9ni_Ye7tb{Fe@w~oHBw-zt4z@(MQ zJl{(mQk^ex{+&CnAw4iaLmYJm;*!Krh|eJI_($0KyHoxnggt{Kmyl=wyRXlQ<2Dcp zA2p`GpB+KWJ7kB2B!t z+-A- J2+7y$qVAfv`yCOm9sT#>#)Vmmft9Q0g@$XYc$L-}_W1R$Mcu7d1I#z>%` z2>%jvS1St(H&?b_H;$jmo|U*9o5_v|JYl{hV_6U7z~m95EaP4*@olQ`Y4(Ul(zH{w z->d#~dn_0qR*qZxP7_)v`o;P^OlNVNOvQwuHoekoV`6E-x4=v_o=oVc`x@i{LjLiL z1jgw|=uYGaa?2c1C5!n%a0aq?>}Y6=)x9 zG5Te{-+NCJj?5wNicBRryVX1OJJF}|_&*jUrmPTKGLb{4XK}B`ic;eAT)%A1egdE> zy~XogeCT3kdQ77cAl5#^OYy@@L90G?UG$?LfqpU&qA?SAmlNVun}smK{UwC$;2r## z&`{oxd5dgLZJ-wqEA9QJ1CzOw#s>eFPStlqc1tAtskjI~0Mgmy^8bcN=o|{yTpze zZe-C9gA0AA!JPv?cl#P1*L3-p!0Kj!5)TLd3h+Q}Y_*oL;j$DXw-M@AhFau|aTn@1M{>Hg`j=F0rF?_Qh* z`j;opUYNCK96vpIZcALd4{~K%HzuRHm72R&jL_&=r6@Gcl*b<$)~VGZe2F%X%g{&= zw$@a*D%Z)sLJzM&7Prua%jM1vQ6VX&z%727@6b*u{n0gx_?<)gG^&dA)yJ_+Oh!Ux zFSrFwPLOaiDpP_S{PHjov+SrECqpfzZwX?V8~|-nC&5zT{7_a=#;x7P_@0A7hGl@S zhb=ZX$Y_F2vXu|IwS$%=88s^j%K$*+));qT<&Tg>kJ~&ip*;omiL}G44CN1Xi3S!!fM9tIj zLd-)Oil5{@pbhn78z{JuP4ee`(||FfPNKfo>)$itxZm1G%wmx!$mJ5}%wqXD;?`6J zpe3vc?OSWaGQ=`km_gn!ogUru&$0WYrS4V4eC#?RG0tH|q-4Q~7LnX;(z3uNc$0MV z>q<(ZF~|Ta#L_6ssmkfRdBSvRf215%K_=ScGustBbng9gmVdmCQU(G8nqOZr61fS} zms4;k| zVYg7*anFm#t?w5e2>#D$6r;tEdtRbSRbjh8393kjDQh_xT*BrTWgFXzXE0q{D2Io% zJ*`E|TM_SP*lkz?-}}T7qSM1}Q=TkK1ztru;dpuL>`UoKZ-o(A0odRm&uOWwN8H&75 z$dRtS*QD|4pw$o@Ke0YX#}MJ02_q>rH9~v$9cY?5*RlDX^*Y~ye#zF#CpyJ?b9lpo z&MqRnPPW2*2h)Bo7H@jH7v1+KoYrh3S&v9;^fm3I~OuY@cRP`QOZ zbEcQS-R%9aJ-8{Pzm@w5>RaPfA_G>tyKc;oJ|@B5t9)MML|@E`l+9sF4`%qmhb&lR zYC80U(w-)MJB9=DUt0bTL3beLfCxJ6)-(AOS}m*s=(fX$9ukUoGe*{UdG-ExOLC#( zr1dhZfvO@oXA7=`zU_SeqR)+Z@8%y|&d#^zXGf-KGW4?pj&oieR}Jn5xLgWmoM6PQ zKib6>_nzHcTDv@0@aO>00}kgw50{P6_|r{0rasp{){{{-2eQ`|8!T+i3zjJ|bqqpS z8d;=xn(U$u2Wn9lD=heH1xJw0f21UXp0kvVE?Jw|z*t)n!&uwu!dN>Bz*xK9#+^?# z9*$~8yim**8v~@rIKL(FyONNstMH>a5pbk2wKcD=M&n$nge9ur$FpNLeFG|iZqb&Y z)Mj)k4XecW=Ajzb>^lsrQK2c zax&fF6D_jfaJY6OW7SDYr&K{G%CYXI-U$g})j=rWTOZf+Rh<{ zC%&Ucoquj01`r#N!Q!l4)T~wnCq&&qC~#ZlN3~E4sILm~THL7K#KC1v)-+2HM!YdT zbm1BRIGip5xH?*{WhEl8I6GPp4StT{7ytsjNuSsW!2^NL3yqVF8?=q6wVBWVn1s?Y zWwgXM4v!WxGXh?|h4A6(^Y_436bMQ@6)}Y>U%xTL0t9Mp0oA>fUMu94t#^K2pc16Synipuj8zADJ%?TmP`U50CWynx9cxUYlgHz2<=}OHoCpbBhgZ?}8WA#yO6|^9 z+^4zis_Y!`N@g4VdSrBx2%1H^qi8f1xk-h=_o@}O6|({)aC&fp4M}VGZXoL8XO4Y1 zmEOnOBo1IRv{fC{&t9Wav_J6j!LG7jS~P|gX_J^OOepNdttnc{)J$yQNE*g8X=h5q zd@y?BMC^`b$kTxYPn~}`+5fizAT%-%-~$N&_y0M|=lT@@67(Pe05g1@`BIdk6UPjH z3O>Bth4O1hMdRvG9fw4b0w2@a4R~y)yKkx1O_wE@%je)H}=nfm4{U%^fWWBYvVai+jzJs8E^vV+%<- zy6#G8%~yjs_AWHxXvhY}z62VbYH`5u6q z^|;&Gp{WgkEA1J{P?+$@{Zj6u)K$H8%ub>Bx=e}_7Ab2bVNOKU=tQULl$!Ro;*pGO z(O$aa(X0J17iZel+fI~TY#S4{I}|^e{v49Gg<6{T=)Tu9c7EZPog;4qb#}mxNq|8q z4xO-a*(r9`1UWwPI(N`qzgLHL`8)UXBl2`5=C`~nZOAM${ONUv;T+Opj}8QZ)o;l@9_rw=o5WRuhp4<^LToFG`{O4K$>HeLpN{qCUIwL zV?H2e#mI5Qio;(IP!tjPWWZ10uzHYfpw}oZ?LlJBWt&P7#j5cB3+pmfTMdhZhpkTR z;aDy7V!H)xEy4&>q99%oPdw8!p=_ZwTEUVVyqfcE+?A@1N6`#rL@5qPhqjJ`$vJA= zC(^1Z`3G2IFI>_tCK`L0BHx7;#IUDcU2&RDnU4;pihu}9pBhq|Zr@@gpWbF2jz_yS z#e-%3DBnWO99EA zCs&uj*-9GdVp-DrT@?j$Q+Oh7f25^Oz4?QJ+eK?_x>&!&-`0GlBc>XnZmMC?=8bqP zI5l9?PVsA&a0A+_vTy_HuT$@|1vcvj;m7v1S16-<+1XuMh^Psgu31uv*7ZLZ=k_8( z?qLR0hic|R2J!DlIZaYgG%2WuQbROCW~n-*t2O%;k=oX{h*k*hNqp;NTpO z(qOV9jHW~YK|#>k@1ji?ky9wC4|b`>pox^~)cSPZYTKC1BerQSxc5}@q7_IVVh&JB zP^Y$WxHw0J>R*5Q_6zPei|2vFX=DE`x;V->{WKj#6H${YAD|vG8}h=m69UeggDl}s zaqX3}0B?z;KRw+ovZA|emR0`X<~E2wGojHAiSCS!KU;+(B9{(<#HEmAsxkR$UGQ4u zy)Kply|yDUNXsDX`vhe9BL4RBp`Xu#t|f?x;ujqHCxaaTB1XQmHShw1c@Xa?irHC5nifR%- zjYKb3JW3~#O$o1MK?BFx;MrH4+u_>b9jY_6+waFqufVKD((8X;8RT67-4VCe5qh1a zMWqO7MbqX;*o;@yj;gOzvtVlvxubr^H;N!8yUDrN%IZ}mq1f8V@yPNtcg`Y~jI^&MIQb25$X)%)>p4*vQ+a{h zXdc>jjaDRKx}{jDVEk(eF_HA<%qd3!O46hOg3tmB(V^~xZ!mn;JkITwRZWhjqF*}R zNHp@*3t5OPv)jKCc+lD-xyA3g1ULvij~h5b6GjQ*mQu=Q5&1F(ZWh*`zIb{34REAd zw){2BEADYJcJyJ>Y2k>smM;$<+~MJII#^-2cgWtQ7vJmYd78bsXf=a!iVr?*C%Xr0 zbj~B4;j24ovU*GmGEsje|(J z%OVYD-Ow4O&k%>x&5a4Wkl;>Y^yFv95;mpOnRF@;hSI}yw#16c3*PyC^aSfBsqj;E z$9lTaFPYo@Gl$=R@c+d=@-VGw|3-p&YCt3%w2%0mrG z6+g|5SB23hH0&5k(RgkNNEJCI-ryPVg-t$p-nNL5vOJpZy2=lMH#KxF;Re^|Wu$qU zidjpxu|>mqw40aW%8$Od=>cJC&(OT)>6LGcsXr?6ESKyoHxpF*DAtd6mQH?mbi<%(G)_zq zbnx8$j@BrdQq86@a?%e&{2Jt1Lx`s`r<$&#alIfq11*6IN}k}jE=1(&6Urz5xb*FK zJR1Hupc&K8)SF_8=jCW-Vf6JmE1ro+A1Rfun(V8g+C@9Y!w9&w+%FsnYzrzkKvVu z_gMD>mYv_N<=Z3B0AupA-CK)LJd!1XJ8;wWM9zz|(TD`^z#e(JTmqc1&qogTXU92g z1xv3oSk)`+rRtkB z;>Ax6$Vi_UkT+B$&ehbS=SRkkg3p8EgdF@OuIQVE2joQB#-4lFo;*aS&TTKvDbP8d z6jE2+gTZ($Bs34lCcKo4Goj|Op~L~Kwim6O?S!YKj)H2e1`DETqdfXeYlnlqwJ~)~ zb$78nVq_(SQ+pqg35c&WaG*ceniVELRY$$?2f*nUJO$y(3=*OSX5v~6PBgfQ6qjCQ zA5|=rE<AkL zIL(iYM*OR|G2SPX6lEI2<%Ol-$q<6*YvNF3N7?AfCW zebZv?@>rT3r?6Yxh)^Wx#G11F1Trkx#`8a6*q0d>S$=Il-0g{eMgP2^()7s6Z^8dU zRc~7ul_T)<-i&kSxOJ7Z!pKD}w+ntlUA7j@Ul7{8ZwM3P_5O+zBo7(Ar3 z^GB3$b@R5faQ$@@t6|`n$&TxvQ~zXqlTB;|NMQRripyfr`X#d@8q;;)~8;HQuzrs&>!>}PCBOW(?@aU zlnrXzQ;pj*iIs(X<7Htp{AXb{*q@sk4Y8)czI4{Exwb{d#WT`sC*NqN!WHwf1>h>k*?UUke=h_;IKaS5I)BcCTN6SHC0 zP0rHaJr3M583QhVy{b+h8rz*B`QUREK<;NSLn2 zoGe*N!CMQN5|;Zk%>y$;|1F4Bi`iDFTp+8DTjUeLn|mo)%jPU%}4NetR-e)%$R^ z?o2${ia%)E%}lFfq+yL(IKeh)Nb-nE*(yG4l5;uLw1bHo#xXP-rI>9dT?xYeeAF7v z_|XPo*UEFF$K^6p=$XxAZ2FJv(>dWg<;3s86fe8weK4;!Kc{avKc?f|Q}ou&6Fe5! zBfQ^m4md%kNoy0-wml&!u_2u7K81a1HVD*paHyNmyZ#o=+h+d0DSD2CEn~HuH`DGQ z;_=J4+;?x8ZwEfKGve%eFQAE&h(gH3S7LcUyUqItp08l6UbV3Gwgi&Fb)*{H2J>c4 zhc~4eNgLwBZN3rFTbI`1-hAF(BXvWAc>87#B*Q#Hi=&@iFTlv%5CTb5Brw4RutcJg z2WQ?@vVdJwzvY6IUSeMaVJ|XY?3fB3w#3J@4AW%L_n^Aehs_xaPiIX-{-H-c+m(x*6Qp9ukO;b`}TW+Zmn?C)k|(^EO_X+ksh z`_HzlE_uc=e995jb++F`TdyA}TX3P1a|t~pJQ!+75q_f5G&X^aE}E!ey1=;WZGv7$ z@?$&I3nqsRpg+y;I)QU=VT>2xQ5%u|x+tqeGS^^F3f$iV8a1a<*DfrAOtEwhH_U4y zS?2I`Sg4{J6z4>nx(9+-@FxxJWPg5Z7xwG33uHRk&s=xb=Jh5;XMf8_|H0{)sP96r z9L4DQJdHmJnHR><9hjx8>6?q;);#S*wJnZc3DvW)NrH}x6_@z4@*$n~CS$_$S~KGnkyixV2savHb! zNL<-&gLaI!Tk#^zE{HrzT-H;{)Yq@?JA8Z&q+=9TkL975I2qHbyZr5=P~$L6obfyZ z@H{>j4_tz!a&hsXCf_cz6^G~VtDf^*`-Jl6^1mT;CEN+sp%$@k8#o{!;m(MwuO za2T|r;=5X34-@qZF)4GyM?pP%3A~ZcjFLQPhwdL#mtPm7TUWiGs>jK#tO#B<{_tZ% zRUfy%FbF23>Z3qhJ|#J6D(hpFHJ;*NY7Wn!Y?r*@;C}g}Y_U4VTtU1<%%K>`Hx4k+ zUzpHIP0=EOZ{GMrVt+nUL0XZEeSIj&ZTP2#5sH3av9-|Sfu<=Q3tBz>Mq_rGlp|)e z(~!D~v5Da1&$B}|aj*+Rz=Ak~(X<)&rI7y5?wtWt;t3(@62%zBzPI*DTyia1ygC5X5Jp*4{)= z|H!Ag7Io^>d7>5_P->ndLre4=Lq8pnu~1GAQkt`T>ZL zznfZTsyeZgHdEjgNc@!-@;m)u-Or#|A@S?q_lf`G*Zjx*-*kE@LjRrR_fpPZEP&^~Sbi_; z{7&$Dmj4%lI?XSFzjFTHp}(g{e?isg|A79UF#XQ(&jJ50JQUOb0~FN1g#X{+|E$)3 ehs!em4gRNgt0=%hEDZ_@_2(bNSm^*i|NDQ&gh0pu literal 0 HcmV?d00001 From 80b721f7a51ff0393d3504d1759ad42a777dfe79 Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Mon, 12 May 2025 18:53:36 +0200 Subject: [PATCH 20/23] tweak README, cleanup --- NAMESPACE | 1 - R/repgrid-output.r | 15 +++++---------- README.Rmd | 5 ++++- README.md | 5 ++++- man/colorize_matrix_rows.Rd | 26 -------------------------- 5 files changed, 13 insertions(+), 39 deletions(-) delete mode 100644 man/colorize_matrix_rows.Rd diff --git a/NAMESPACE b/NAMESPACE index 639d774..563e040 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -70,7 +70,6 @@ export(center) export(clearRatings) export(cluster) export(clusterBoot) -export(colorize_matrix_rows) export(constructCor) export(constructD) export(constructPca) diff --git a/R/repgrid-output.r b/R/repgrid-output.r index 1ded897..7eea39c 100644 --- a/R/repgrid-output.r +++ b/R/repgrid-output.r @@ -145,19 +145,15 @@ make_sep_mat_atomic <- function(sep, nr) { } - #' 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. +#' 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 +#' @param colors crayon colors as a string. One of `black`, `red`, `green`, `yellow`, `blue`, `magenta`, `cyan`, +#' `white`, `silver`. +#' @noRd #' @examples #' m <- as.matrix(mtcars) #' colorize_matrix_rows(m, "red") @@ -166,7 +162,6 @@ 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) diff --git a/README.Rmd b/README.Rmd index 24d923d..b9a2b9e 100644 --- a/README.Rmd +++ b/README.Rmd @@ -84,9 +84,12 @@ Conduct](https://github.com/markheckmann/OpenRepGrid/blob/master/CODE_OF_CONDUCT If our software makes your life easier, consider sponsoring us — think of it as buying us a coffee while we keep hacking away! [![Donate](https://img.shields.io/badge/Donate-❤-EA4AAA)](https://github.com/sponsors/markheckmann) -#### Contributors +#### Authors - [Mark Heckmann](https://markheckmann.de) (package maintainer) + +#### Contributors + - Richard C. Bell - Alejandro García Gutiérrez ([\@j4n7](https://github.com/j4n7)) - Diego Vitali ([\@artoo-git](https://github.com/artoo-git)) diff --git a/README.md b/README.md index 9beffeb..5fb8fee 100644 --- a/README.md +++ b/README.md @@ -100,9 +100,12 @@ If our software makes your life easier, consider sponsoring us — think of it as buying us a coffee while we keep hacking away! [![Donate](https://img.shields.io/badge/Donate-❤-EA4AAA)](https://github.com/sponsors/markheckmann) -#### Contributors +#### Authors - [Mark Heckmann](https://markheckmann.de) (package maintainer) + +#### Contributors + - Richard C. Bell - Alejandro García Gutiérrez ([@j4n7](https://github.com/j4n7)) - Diego Vitali ([@artoo-git](https://github.com/artoo-git)) diff --git a/man/colorize_matrix_rows.Rd b/man/colorize_matrix_rows.Rd deleted file mode 100644 index 5195209..0000000 --- a/man/colorize_matrix_rows.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/repgrid-output.r -\name{colorize_matrix_rows} -\alias{colorize_matrix_rows} -\title{Colorize matrix cell rows using crayon colors} -\usage{ -colorize_matrix_rows(m, colors = "white", na.val = "white") -} -\arguments{ -\item{m}{A matrix.} - -\item{colors}{crayon colors as a string. One of -black, red, green, yellow, blue, magenta, cyan, white, -silver.} -} -\description{ -Atomic matrices can be wrapped into crayon color codes without -destroying the structure or alignment. Used to indicate -preferred poles. -} -\examples{ -m <- as.matrix(mtcars) -colorize_matrix_rows(m, "red") - -} -\keyword{internal} From ce65ef07b8abe46d4732a6aacea62ae44b7c88b4 Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Mon, 12 May 2025 18:56:29 +0200 Subject: [PATCH 21/23] add functions to gh-pages --- _pkgdown.yml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/_pkgdown.yml b/_pkgdown.yml index c55ab06..d9394c5 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -66,8 +66,10 @@ reference: - constructPcaLoadings - constructRmsCor - constructs + - preferredPoles - alignByIdeal - alignByLoadings + - alignByPreferredPole - permuteConstructs - title: Distances @@ -119,11 +121,11 @@ reference: - title: Import and Export Data contents: - importExcel + - importTxt - importGridcor - importGridstat - importGridsuite - importScivesco - - importTxt - saveAsExcel - saveAsTxt From 1f47ce19ea9c5a6733a9bf45f6631149224b9cc4 Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Mon, 12 May 2025 18:57:00 +0200 Subject: [PATCH 22/23] dump dev --- dev/57_valence/57_valence.R | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/dev/57_valence/57_valence.R b/dev/57_valence/57_valence.R index 5e18e66..a97d4ca 100644 --- a/dev/57_valence/57_valence.R +++ b/dev/57_valence/57_valence.R @@ -2,8 +2,15 @@ devtools::load_all() -x <- boeker -# how to disntinguish between no preferred poles available -# and no preference? +file <- system.file("extdata", "grid_01b.txt", package = "OpenRepGrid") +importTxt(file) + + +file <- system.file("extdata", "grid_01.xlsx", package = "OpenRepGrid") +importExcel(file) + + +file <- system.file("extdata", "grid_01b.xlsx", package = "OpenRepGrid") +importExcel(file) From c1e1954d4970fd0e5b07f57021998591e29258b8 Mon Sep 17 00:00:00 2001 From: Mark Heckmann Date: Mon, 12 May 2025 19:00:24 +0200 Subject: [PATCH 23/23] tweak docs --- R/import.r | 4 ++-- man/importTxt.Rd | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/import.r b/R/import.r index ab23c41..be66d3f 100644 --- a/R/import.r +++ b/R/import.r @@ -1405,8 +1405,8 @@ importTxtInternal <- function(file, dir = NULL, min = NULL, max = NULL) { #' rg <- importTxt(file) #' #' \dontrun{ -#' # To see the structure of the Excel file try to open it as follows. -#' # May not work on all systems. +#' # To see the structure of the file, try opening it as follows. +#' # (may not work on all systems) #' file.show(file) #' } #' diff --git a/man/importTxt.Rd b/man/importTxt.Rd index 2dc87bc..22d67ba 100644 --- a/man/importTxt.Rd +++ b/man/importTxt.Rd @@ -91,8 +91,8 @@ file <- system.file("extdata", "grid_01.txt", package = "OpenRepGrid") rg <- importTxt(file) \dontrun{ -# To see the structure of the Excel file try to open it as follows. -# May not work on all systems. +# To see the structure of the file, try opening it as follows. +# (may not work on all systems) file.show(file) }