diff --git a/DESCRIPTION b/DESCRIPTION index af26c8d6..1289d6b2 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.9006 +Date: 2025-05-12 Encoding: UTF-8 URL: https://github.com/markheckmann/OpenRepGrid Imports: @@ -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 94fa0f81..563e040f 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) @@ -44,6 +45,7 @@ export(addIndexColumnToMatrix) export(addVarianceExplainedToBiplot2d) export(alignByIdeal) export(alignByLoadings) +export(alignByPreferredPole) export(apply_pb) export(as.gridlist) export(bertin) @@ -68,7 +70,6 @@ export(center) export(clearRatings) export(cluster) export(clusterBoot) -export(colorize_matrix_rows) export(constructCor) export(constructD) export(constructPca) @@ -150,6 +151,8 @@ export(orderByString) export(permuteConstructs) export(permuteGrid) export(perturbate) +export(preferredPoles) +export(preferredPolesByIdeal) export(prepareBiplotData) export(print_square_matrix) export(quasiDistributionDistanceSlater) @@ -182,7 +185,6 @@ export(settings) export(settingsLoad) export(settingsSave) export(shift) -export(showMeta) export(showScale) export(slaterStandardization) export(ssq) @@ -190,6 +192,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 +230,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 db7adfde..fa1fdb08 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,14 @@ +# OpenRepGrid 0.1.18 (dev version) + +* `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 + 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) + # OpenRepGrid 0.1.17 * `clusterBoot` gains `trim` arg. Construct labels in dendrogram are no longer trimmed by default (#58). @@ -51,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/calc.r b/R/calc.r index 9e3d1774..e5ebae6a 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 @@ -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, ] } diff --git a/R/distance.R b/R/distance.R index 55c9dab7..d5c74d39 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 @@ -449,7 +448,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 +500,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/R/import.r b/R/import.r index 18c6b330..be66d3f2 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 + # $ preferredPoles :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$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_poles + } 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$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 op <- options()$warn options(warn = -1) @@ -1316,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*). #' @@ -1348,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 @@ -1376,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) #' } #' @@ -1405,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", @@ -1496,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`) @@ -1525,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/R/openrepgrid.r b/R/openrepgrid.r index f420525f..e07d5ea4 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 00000000..01ac437a --- /dev/null +++ b/R/preferred_poles.R @@ -0,0 +1,144 @@ +#' Get / set preferred construct poles +#' +#' 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`. +#' 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) + 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_ + ) +} + + +#' @export +#' @rdname preferred-pole +`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.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) + 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 +} + + +# 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) +} + + +#' 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 +#' @family align_constructs +#' @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. +#' 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 [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)) { + 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 <- alignByPreferredPole(x) + } + x +} diff --git a/R/repgrid-basicops.r b/R/repgrid-basicops.r index 82a39ff9..a7a42622 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. #' @@ -1582,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 83729e4b..7eea39c6 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) @@ -191,6 +186,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 @@ -204,13 +208,15 @@ 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 + 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 { # sanity checks if (length(trim) == 1) { # if only one parameter given, extend to the other @@ -253,16 +259,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 @@ -283,27 +296,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 @@ -440,13 +460,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( @@ -487,6 +518,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) } @@ -500,29 +539,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. @@ -535,7 +551,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 @@ -557,7 +574,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, show_preferred = show_preferred ) cat("\n") if (do.bertin) { @@ -565,6 +583,7 @@ setMethod("show", "repgrid", function(object) { } }) + # # Show method for repgrid # # @param repgrid object # setMethod("show", signature= "repgrid", function(object){ diff --git a/R/repgrid-plots.r b/R/repgrid-plots.r index 70420b0c..2dd45d02 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/R/rgl-3d.r b/R/rgl-3d.r index c65ab5bb..cdadd575 100644 --- a/R/rgl-3d.r +++ b/R/rgl-3d.r @@ -148,12 +148,7 @@ 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.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) } @@ -223,7 +218,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 @@ -313,14 +308,12 @@ 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. +#' @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 @@ -333,18 +326,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.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)`). +#' @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. -#' #' @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. @@ -354,6 +354,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: @@ -371,45 +372,27 @@ 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 = TRUE, - lef = 1.3, center = 1, normalize = 0, g = 0, h = 1, col.active = NA, - col.passive = NA, - c.sphere.col = grey(.4), c.cex = .6, c.text.col = grey(.4), - e.sphere.col = grey(0), e.cex = .6, e.text.col = grey(0), +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.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.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, unity = unity, unity3d = unity3d, scale.e = scale.e, zoom = zoom, ... diff --git a/R/settings.r b/R/settings.r index 77de51f0..55a9865b 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/R/utils.r b/R/utils.r index 832946c8..1851bfd4 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 #' @@ -834,6 +839,44 @@ 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 +} + + +#' 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/README.Rmd b/README.Rmd index e0cedb7a..b9a2b9e2 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. @@ -76,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 5c694a8c..5fb8feef 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, @@ -90,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/_pkgdown.yml b/_pkgdown.yml index c55ab06e..d9394c5c 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 diff --git a/dev/57_valence/57_valence.R b/dev/57_valence/57_valence.R new file mode 100644 index 00000000..a97d4ca9 --- /dev/null +++ b/dev/57_valence/57_valence.R @@ -0,0 +1,16 @@ +# feat: add construct pole valence (positive/negative/neutral) to repgrid object #57 + +devtools::load_all() + + +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) + diff --git a/inst/examples/example-biplot3d.R b/inst/examples/example-biplot3d.R new file mode 100644 index 00000000..1254be66 --- /dev/null +++ b/inst/examples/example-biplot3d.R @@ -0,0 +1,14 @@ +\dontrun{ +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") +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/inst/examples/example-preferredPoles.R b/inst/examples/example-preferredPoles.R new file mode 100644 index 00000000..08371cfa --- /dev/null +++ b/inst/examples/example-preferredPoles.R @@ -0,0 +1,20 @@ +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 + +# remove prefernces +preferredPoles(x) <- NA +x diff --git a/inst/extdata/grid_01.txt b/inst/extdata/grid_01.txt index c0f0d03d..6c079441 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 866b074b..5e1f4ab9 100644 Binary files a/inst/extdata/grid_01.xlsx and b/inst/extdata/grid_01.xlsx differ diff --git a/man/alignByIdeal.Rd b/man/alignByIdeal.Rd index dd4b5054..95e8fe86 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 6312c0b9..6c93b67a 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 new file mode 100644 index 00000000..524682f4 --- /dev/null +++ b/man/alignByPreferredPole.Rd @@ -0,0 +1,33 @@ +% 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_positive = "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{ +x <- preferredPolesByIdeal(boeker, "ideal self") +x <- alignByPreferredPole(x) +x +} +\seealso{ +Aligning constructs +\code{\link{alignByIdeal}()}, +\code{\link{alignByLoadings}()} +} +\concept{align_constructs} diff --git a/man/biplot3d.Rd b/man/biplot3d.Rd index aa927c32..e1e9aedf 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,9 +17,13 @@ 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, 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), @@ -71,12 +75,27 @@ 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.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.} \item{c.cex}{Size of construct text.} \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.} @@ -113,24 +132,19 @@ 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, 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") 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 diff --git a/man/biplotDraw.Rd b/man/biplotDraw.Rd index 756c0e9b..cd3be965 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, diff --git a/man/colorize_matrix_rows.Rd b/man/colorize_matrix_rows.Rd deleted file mode 100644 index 5195209a..00000000 --- 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} diff --git a/man/distanceHartmann.Rd b/man/distanceHartmann.Rd index 527c8a3c..40ff949b 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 diff --git a/man/importExcel.Rd b/man/importExcel.Rd index 920ae508..8f1a5525 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 4710e51f..0c74e43c 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 e43f79d0..22d67ba1 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 @@ -82,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) } diff --git a/man/preferred-pole.Rd b/man/preferred-pole.Rd new file mode 100644 index 00000000..98f8aa88 --- /dev/null +++ b/man/preferred-pole.Rd @@ -0,0 +1,43 @@ +% 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, usually with one pole being preferred (positive). +Setting the preferred poles may is useful in 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 + +# remove prefernces +preferredPoles(x) <- NA +x +} diff --git a/man/preferredPolesByIdeal.Rd b/man/preferredPolesByIdeal.Rd new file mode 100644 index 00000000..64c1039f --- /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[=alignByPreferredPole]{alignByPreferredPole()}}.} +} +\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/print.distance.Rd b/man/print.distance.Rd index de307f72..9fa370d9 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 2417d6ec..055e03fe 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.} diff --git a/man/roxygen/meta.R b/man/roxygen/meta.R new file mode 100644 index 00000000..44900ab4 --- /dev/null +++ b/man/roxygen/meta.R @@ -0,0 +1,3 @@ +list( + rd_family_title = list(align_constructs = "Aligning constructs") +) diff --git a/man/settings.Rd b/man/settings.Rd index 769e0380..3ac817bc 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{ diff --git a/man/showMeta.Rd b/man/showMeta.Rd deleted file mode 100644 index 5cb640d7..00000000 --- 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} 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 00000000..d28be732 --- /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-calc.R b/tests/testthat/test-calc.R new file mode 100644 index 00000000..e55971e9 --- /dev/null +++ b/tests/testthat/test-calc.R @@ -0,0 +1,20 @@ +# 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-import.R b/tests/testthat/test-import.R new file mode 100644 index 00000000..64a4b040 --- /dev/null +++ b/tests/testthat/test-import.R @@ -0,0 +1,50 @@ +# TEXTFILE -------------------------------------------- + +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)) +}) + + + +# 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-preferred-pole.R b/tests/testthat/test-preferred-pole.R new file mode 100644 index 00000000..5f695859 --- /dev/null +++ b/tests/testthat/test-preferred-pole.R @@ -0,0 +1,19 @@ +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)) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R new file mode 100644 index 00000000..d511ba47 --- /dev/null +++ b/tests/testthat/test-utils.R @@ -0,0 +1,29 @@ +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)) +}) + + +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")) +}) diff --git a/tests/testthat/test_bertin.R b/tests/testthat/test_bertin.R index 3817c000..9b2da79d 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/test_biplot.R b/tests/testthat/test_biplot.R index c1c81a36..f468b3ad 100644 --- a/tests/testthat/test_biplot.R +++ b/tests/testthat/test_biplot.R @@ -1,7 +1,6 @@ library(testthat) library(vdiffr) -library(vdiffr) test_that("biplots work", { create_biplot2d <- function() { diff --git a/tests/testthat/testdata/grid_no_preferred.txt b/tests/testthat/testdata/grid_no_preferred.txt new file mode 100644 index 00000000..847b67bc --- /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 00000000..7e34bfc1 --- /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 00000000..1d8dc3d7 --- /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 00000000..cb925b23 --- /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 ---------------- diff --git a/tests/testthat/testdata/grids.xlsx b/tests/testthat/testdata/grids.xlsx new file mode 100644 index 00000000..94a40e0f Binary files /dev/null and b/tests/testthat/testdata/grids.xlsx differ diff --git a/tests/testthat/testdata/issue_22.txt b/tests/testthat/testdata/issue_22.txt new file mode 100644 index 00000000..fb445a72 --- /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 00000000..c2c06856 --- /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