diff --git a/.Rbuildignore b/.Rbuildignore index 35fbc1ad..dbaeafaa 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -21,3 +21,4 @@ TODO.md vignettes ^revdep$ CITATION.cff +^.claude diff --git a/DESCRIPTION b/DESCRIPTION index 3ae18c36..14bab4f0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -70,7 +70,7 @@ Collate: 'utils-import.r' 'utils.r' 'zzz.r' -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 NeedsCompilation: no Suggests: rgl, diff --git a/NEWS.md b/NEWS.md index 511a7ff9..be649743 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,8 @@ # OpenRepGrid 0.1.19 (dev version) +* `biplot2d`: Construct pole labels are automatically colorized by preference status (green = preferred, + red = non-preferred, dark gray = neutral/undefined) when preferred poles are set in the repgrid object. + New arg `c.color.preferred` controls the behavior (`NULL` = auto-detect, `TRUE` = always, `FALSE` = never) (#71). * drop `{styler}` dependency (#72) # OpenRepGrid 0.1.18 diff --git a/R/bertin.r b/R/bertin.r index fcdba876..4540f213 100644 --- a/R/bertin.r +++ b/R/bertin.r @@ -5,7 +5,6 @@ # ////////////////////////////////////////////////////////////////////////////// - constructCellGrob <- function(text, gp = gpar(), horiz = TRUE) { gp <- modifyList(gpar(fill = grey(.95)), gp) col <- gmSelectTextColorByLuminance(gp$fill) @@ -19,7 +18,6 @@ constructCellGrob <- function(text, gp = gpar(), horiz = TRUE) { } - bertin1 <- function(x, draw = TRUE) { if (!inherits(x, "repgrid")) { stop("Object must be of class 'repgrid'") @@ -88,9 +86,6 @@ bertin1 <- function(x, draw = TRUE) { } - - - bertin2 <- function(x, ratings = TRUE, top = unit(40, "mm"), sides = unit(40, "mm"), left = sides, right = sides, cell = unit(6, "mm"), cell.height = cell, cell.width = cell, @@ -176,7 +171,6 @@ bertin2 <- function(x, ratings = TRUE, top = unit(40, "mm"), sides = unit(40, "m } - bertin2PlusLegend <- function(x, ratings = TRUE, top = unit(40, "mm"), sides = unit(40, "mm"), left = sides, right = sides, cell = unit(6, "mm"), cell.height = cell, cell.width = cell, @@ -215,8 +209,6 @@ bertin2PlusLegend <- function(x, ratings = TRUE, top = unit(40, "mm"), # bertin2PlusLegend(rg2, colors=c("darkred", "white"), top=unit(4, "cm"), sides=unit(4, "cm")) - - # TODO: -may work with closures here to store old row and column when marking # rows and columns? # -splitString has a bug, breaks too late diff --git a/R/calc.r b/R/calc.r index e5ebae6a..4a4a272f 100644 --- a/R/calc.r +++ b/R/calc.r @@ -154,7 +154,6 @@ statsDiscrepancy <- function(x, disc, sort = TRUE) { } - # ///////////////////////////////////////////////////////////////////////////// # order elements and constructs by angles in first two dimensions from # singular value decomposition approach (cf. Raeithel ???) @@ -273,7 +272,6 @@ reorder2d <- function(x, dim = c(1, 2), center = 1, normalize = 0, g = 0, h = 1 } - #### __________________ #### #### ELEMENTS #### @@ -547,7 +545,6 @@ print.constructCor <- function(x, digits = 2, col.index = TRUE, } - #' Root mean square (RMS) of inter-construct correlations. #' #' The RMS is also known as 'quadratic mean' of diff --git a/R/data-openrepgrid.r b/R/data-openrepgrid.r index 12029b02..e4882b8d 100644 --- a/R/data-openrepgrid.r +++ b/R/data-openrepgrid.r @@ -278,7 +278,6 @@ NULL # save("feixas2004", file="../data/feixas2004.RData") - ## Leach et al. (2001) ---- #' Pre- and post therapy dataset from Leach et al. (2001). @@ -335,7 +334,6 @@ NULL # save("leach2001a", file="../data/leach2001a.RData") - # name.abb <- c("CS", "SN", "WG", "MG", "Fa", "Pa", "IS", "Mo", "AC") # not included yet # args <- list( # name= c("Child self", "Self now", "Women in general", @@ -369,7 +367,6 @@ NULL # save("leach2001b", file="../data/leach2001b.RData") - ## Mackay (1992) ---- #' Grid data from Mackay (1992). @@ -458,7 +455,6 @@ NULL # save("raeithel", file="../data/raeithel.RData") - ## Slater (1977a) ---- #' Drug addict's grid data set from Slater (1977, p. 32). diff --git a/R/distance.R b/R/distance.R index d5c74d39..13dbfa30 100644 --- a/R/distance.R +++ b/R/distance.R @@ -322,7 +322,6 @@ quasiDistributionDistanceSlater <- function(reps, nc, ne, range, # } - # Return a list with the mean and sd as indicated in Hartmann's (1992) paper. # getSlaterPaperPars <- function(nc) { diff --git a/R/export.r b/R/export.r index 1f2956b1..cb0684be 100644 --- a/R/export.r +++ b/R/export.r @@ -236,7 +236,6 @@ saveAsWorksheet <- function(x, wb, format = "wide", sheet = NULL, default_sheet } - # saveAsExcelv2 <- function(x, file, format = "wide", sheet = "grid") { # ext <- tools::file_ext(file) # if (ext != "xlsx") { @@ -383,7 +382,6 @@ add_one_sheet_with_grid <- function(x, wb, format = "wide", sheet = "grid") { } - #' Export a grid to dataframe with wide format #' @param x A `repgrid` object. #' @export diff --git a/R/gmMain.r b/R/gmMain.r index fe89e249..6fb1ff02 100644 --- a/R/gmMain.r +++ b/R/gmMain.r @@ -78,7 +78,6 @@ gmSelectTextColorByLuminance <- function(hex, breaks = c(-1, 50, 101), breakColo # ////////////////////////////////////////////////////////////////////////////// - # ////////////////////////////////////////////////////////////////////////////// # like a gmTextBox @@ -324,7 +323,6 @@ gmSplitTextBox <- function(text, x = unit(0.5, "npc"), y = unit(0.5, "npc"), jus } - ### NOT RUN # text <- "some random longer text that might be the label of an item" # grid.draw(gmSplitTextGrob(text, horiz=T, just=c("center", "center"))) @@ -352,7 +350,6 @@ gmSplitTextBox <- function(text, x = unit(0.5, "npc"), y = unit(0.5, "npc"), jus # popViewport() - ## matrix of text with random orientation and random fore- and background color # grid.newpage() # text <- "some random longer text that might be the label of an item" @@ -428,7 +425,6 @@ gmMakeVpBorders <- function(side, col, lwd, ...) { # popViewport() - # ////////////////////////////////////////////////////////////////////////////// # gmBulletPointsBox @@ -436,14 +432,12 @@ gmMakeVpBorders <- function(side, col, lwd, ...) { # Bullets can be chosen any pch, numbers, letters or any other vector. - # ////////////////////////////////////////////////////////////////////////////// # gmProfileLines # ask Hadley first if he already implicitly has it... - # ////////////////////////////////////////////////////////////////////////////// # gmRandomColor @@ -479,7 +473,6 @@ gmRandomColor <- function(n = 1, h = runif(n) * 360, s = runif(n), v = runif(n), # gmRandomColor(30, h=100:200, v=3:10/10, p=T) - # ////////////////////////////////////////////////////////////////////////////// # gmArrowIndicator @@ -518,7 +511,6 @@ gmRandomColor <- function(n = 1, h = runif(n) * 360, s = runif(n), v = runif(n), # } - gmArrowIndicatorGrob <- function(angle = 0, col = "black", size = 5, circle = FALSE, initangle = 0, ...) { # gp <- modifyList(gpar(fill="black", col=NA, lwd=1, lineend ="square", # set default gpar and overwrite if provided # linejoin ="mitre", linemitre=1), gp) @@ -715,11 +707,12 @@ gmSelectColorByValue <- function(x, breaks = seq(0, 100, by = 10), # TODO: automatic deterination of wFirstRow by max stringwidth gmLegend <- function( - x, y, pch, symbol = FALSE, col, labels, hgap = unit( - 0.5, - "lines" - ), wFirstCol = unit(2, "lines"), vgap = unit(0.3, "lines"), default_units = "lines", - gpRect = gpar(), gpText = gpar(), draw = TRUE, title = "Legend:") { + x, y, pch, symbol = FALSE, col, labels, hgap = unit( + 0.5, + "lines" + ), wFirstCol = unit(2, "lines"), vgap = unit(0.3, "lines"), default_units = "lines", + gpRect = gpar(), gpText = gpar(), draw = TRUE, title = "Legend:" +) { labels <- as.character(labels) if (is.logical(title) && !title) { title <- NULL @@ -807,7 +800,6 @@ gmLegend <- function( # gpRect=gpar(col=1, fill=grey(.95), lty=3), gpText=gpar(col=grey(.5), cex=.7), title = NULL) - # ////////////////////////////////////////////////////////////////////////////// # gmLegends_2 diff --git a/R/import.r b/R/import.r index 66ee6048..ed657a74 100644 --- a/R/import.r +++ b/R/import.r @@ -20,7 +20,6 @@ # - #' convertImportObjectToRepGridObject. #' #' Convert the returned object from an import function into a `repgrid` @@ -428,7 +427,6 @@ importGridstat <- function(file, dir = NULL, min = NULL, max = NULL) { } - ## GRIDCOR ------------------------------------------------------------------------------------ # gridcor outpout has the following form: diff --git a/R/measures.r b/R/measures.r index d88061b7..3fcbaf75 100644 --- a/R/measures.r +++ b/R/measures.r @@ -374,7 +374,6 @@ indexPvaff <- function(x, method = 1) { # } - #' Bieri's index of cognitive complexity #' #' The index builds on the number of rating matches between pairs of constructs. It is the relation between the total @@ -2304,7 +2303,6 @@ print.indexDilemma <- function(x, digits = 2, output = "SPCD", ...) { } - #' Implicative Dilemmas #' #' Implicative dilemmas are closely related to the notion of conflict. An implicative dilemma arises when a desired @@ -2487,7 +2485,6 @@ indexDilemma <- function(x, self = 1, ideal = ncol(x), } - #' Plot method for indexDilemma (network graph) #' #' Produces a network graph using of the detected implicative dilemmas using the @@ -2510,21 +2507,22 @@ indexDilemma <- function(x, self = 1, ideal = ncol(x), #' @export #' plot.indexDilemma <- function( - x, - layout = "rows", - both.poles = TRUE, - node.size = 50, - node.text.cex = 1, - node.label.color = "black", - node.color.discrepant = "darkolivegreen3", - node.color.congruent = "lightcoral", - edge.label.color = grey(.4), - edge.label.cex = 1, - edge.digits = 2, - edge.arrow.size = .5, - edge.color = grey(.6), - edge.lty = 2, - ...) { + x, + layout = "rows", + both.poles = TRUE, + node.size = 50, + node.text.cex = 1, + node.label.color = "black", + node.color.discrepant = "darkolivegreen3", + node.color.congruent = "lightcoral", + edge.label.color = grey(.4), + edge.label.cex = 1, + edge.digits = 2, + edge.arrow.size = .5, + edge.color = grey(.6), + edge.lty = 2, + ... +) { id <- x # renamed from 'id' to 'x' to match arg in print generic # response in case no dilemmas were found @@ -2651,8 +2649,6 @@ plot.indexDilemma <- function( # } - - # ////////////////////////////////////////////////////////////////////////////// # Pemutation test to test if grid is random. diff --git a/R/preferred_poles.R b/R/preferred_poles.R index 9370d00c..bbaa65ad 100644 --- a/R/preferred_poles.R +++ b/R/preferred_poles.R @@ -143,3 +143,29 @@ preferredPolesByIdeal <- function(x, ideal, none_range = NULL, align = FALSE) { } x } + + +# Map preferred pole status to colors for each construct. +# Returns list(left = , right = ). +# @keywords internal +preferred_pole_colors <- function(x, + col_preferred = "green", + col_nonpreferred = "red", + col_neutral = grey(.4)) { + preferred <- preferredPoles(x) + colors_left <- case_when( + preferred == "left" ~ col_preferred, + preferred == "both" ~ col_preferred, + preferred == "none" ~ col_neutral, + preferred == "right" ~ col_nonpreferred, + is.na(preferred) ~ col_neutral + ) + colors_right <- case_when( + preferred == "right" ~ col_preferred, + preferred == "both" ~ col_preferred, + preferred == "none" ~ col_neutral, + preferred == "left" ~ col_nonpreferred, + is.na(preferred) ~ col_neutral + ) + list(left = colors_left, right = colors_right) +} diff --git a/R/repgrid-basicops.r b/R/repgrid-basicops.r index 653a36c7..5c395745 100644 --- a/R/repgrid-basicops.r +++ b/R/repgrid-basicops.r @@ -429,7 +429,6 @@ ratings_df <- function(x, long = FALSE, names = TRUE, trim = NA) { } - #' Get number of constructs #' #' @param x `repgrid` object @@ -915,7 +914,6 @@ shift <- function(x, c = 1, e = 1) { } - ############################# CHANGE CONTENT ################################# # rating <- function(x, scores=NA, rows=NA, cols=NA){ @@ -923,7 +921,6 @@ shift <- function(x, c = 1, e = 1) { # } - r.setRatings <- function(x, scores = NA, rows = NA, cols = NA, layer = 1, ...) { if (!inherits(x, "repgrid")) { # check if x is repgrid object stop("Object x must be of class 'repgrid'.") @@ -1134,7 +1131,6 @@ addConstruct <- function(x, l.name = NA, r.name = NA, scores = NA, # x <- addConstruct(x) - #### RENAMING #### @@ -1237,7 +1233,6 @@ setConstructAttr <- function(x, pos, l.name, r.name, l.preferred, r.preferred, # setConstructAttr(x, 1, l.n="halle") - # MAYBE OBSOLETE as setConstructAttr does the same. # modifyConstructs() allows to change the properties of a construct (left and # right pole as well as preferred and emergent property). By default the new @@ -1328,9 +1323,6 @@ modifyElement <- function(x, pos, name = NA, abbreviation = NA, status = NA, # x <- modifyElement(x, pos=2, name="test") - - - #' Print scale range information to the console. #' #' @param x `repgrid` object. @@ -1381,8 +1373,6 @@ setCoupled <- function(x, coupled = TRUE) { # x <- setCoupled(x) - - #' showMeta #' #' prints meta information about the grid to the console (id, name of interviewee etc.) @@ -1472,7 +1462,6 @@ makeRepgrid <- function(args) { # x <- setScale(x, 0,1) - #' Concatenate the constructs of two grids. #' #' I.e. the constructs are combined to form one long grid. diff --git a/R/repgrid-constructs.r b/R/repgrid-constructs.r index 7e64f291..4efc9dfd 100644 --- a/R/repgrid-constructs.r +++ b/R/repgrid-constructs.r @@ -23,7 +23,6 @@ # +--emerged - ############## FUNCTIONS TO RETRIEVE INFORMATION FROM REPGRID OBJECTS ################## #' Get construct names @@ -270,7 +269,6 @@ rightpoles <- function(x) { } - constructInfo <- function(x, all = TRUE) { if (!inherits(x, "repgrid")) { # check if x is repgrid object stop("Object x must be of class 'repgrid'.") @@ -306,8 +304,6 @@ getNoOfConstructs <- function(x) { nc <- getNoOfConstructs - - # internal. c_makeNewConstruct is the constructor for construct object (simple list) c_makeNewConstruct <- function(x = NULL, l.name = NA, l.preferred = NA, l.emerged = NA, r.name = NA, r.preferred = NA, r.emerged = NA, ...) { @@ -327,7 +323,6 @@ c_makeNewConstruct <- function(x = NULL, l.name = NA, l.preferred = NA, l.emerge # str(c_makeNewConstruct()) - # internal: c_setConstructs sets constructs by index c_setConstructs <- function(x, l.name = NA, l.preferred = NA, l.emerged = NA, r.name = NA, r.preferred = NA, r.emerged = NA, @@ -395,7 +390,6 @@ c_addConstruct <- function(x, l.name = NA, l.preferred = NA, l.emerged = NA, # str(x@constructs, m=3) - # internal: c_addConstructs. all elements that do not have a position specified are added at the end c_addConstructs <- function(x, l.name = NA, l.preferred = NA, l.emerged = NA, r.name = NA, r.preferred = NA, r.emerged = NA, @@ -432,16 +426,6 @@ c_addConstructs <- function(x, l.name = NA, l.preferred = NA, l.emerged = NA, # str(x@constructs, m=3) - - - - - - - - - - ### maybe unnecessary functions ### # c.removeNullConstructs <- function(x){ diff --git a/R/repgrid-elements.r b/R/repgrid-elements.r index 2f3f5b6c..edf2cad7 100644 --- a/R/repgrid-elements.r +++ b/R/repgrid-elements.r @@ -62,8 +62,6 @@ eNames <- getElementNames # getElementNames(rg1) - - #' Retrieves the element names from a `repgrid`. #' #' Different features like trimming, indexing and choices of separators @@ -116,8 +114,6 @@ getElementNames2 <- function(x, trim = 20, index = F, } - - #' Get or replace element names #' #' Allows to get and set element names. @@ -241,7 +237,6 @@ e.setElements <- function(x, name = NA, abbreviation = NA, status = NA, index = # x <- e.setElements(x, name="test", index=3) # error due to wholes in element list - # internal: e.addElements adds elements to the grid. All elements that do not have # a position specified are added at the end. e.addElements <- function(x, name = NA, abbreviation = NA, status = NA, position = NA, side = "pre") { @@ -284,14 +279,6 @@ e.addElements <- function(x, name = NA, abbreviation = NA, status = NA, position # insertAt(numeric(0), 1:2) - - - - - - - - ### maybe unnecessary functions ### # internal: e.removeNullElements removes non exsiting elements diff --git a/R/repgrid-output.r b/R/repgrid-output.r index 7eea39c6..c3c229e5 100644 --- a/R/repgrid-output.r +++ b/R/repgrid-output.r @@ -105,7 +105,6 @@ bind_matrices_horizontally <- function(um, lm, anchors = c(1, 1)) { } - # break at any point possible break_output <- function(mat, ncolkeep = 14, keeprows = TRUE) { availchar <- options()$width # get console size (problematic update) @@ -460,23 +459,9 @@ df_out <- function(df, # data frame } # colorize constructs by pole preference - 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) + pref_colors <- preferred_pole_colors(grid, col_neutral = "white") + mat.left.atomic <- colorize_matrix_rows(mat.left.atomic, pref_colors$left) + mat.right.atomic <- colorize_matrix_rows(mat.right.atomic, pref_colors$right) # 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 @@ -535,7 +520,6 @@ df_out <- function(df, # data frame # df_out(df, left, right, h=T, cut=25, id=T, show=1) - # Show method ------------------------------------------------- @@ -593,7 +577,6 @@ setMethod("show", "repgrid", function(object) { # }) - # output version for repertory grids: # parameters # diff --git a/R/repgrid-plots.r b/R/repgrid-plots.r index 84e517ca..c390fb1c 100644 --- a/R/repgrid-plots.r +++ b/R/repgrid-plots.r @@ -449,7 +449,6 @@ biplotSimple <- function(x, dim = 1:2, center = 1, normalize = 0, # print(res, table.placement="H", hline.after=c(-1,0,nrow(ssq.table)-1, nrow(ssq.table))) - #' Prepare dataframe passed to drawing functions for biplots. #' #' Data frame contains the variables `type, show, x, y, @@ -1154,8 +1153,6 @@ biplotDraw <- function(x, # biplotDraw(x)) # add amount explained variance to the axes - - #' Adds the percentage of the sum-of-squares explained by each axis to the plot. #' #' @param x `repgrid` object containing the biplot coords, i.e. after @@ -1305,8 +1302,6 @@ addVarianceExplainedToBiplot2d <- function(x, dim = c(1, 2, 3), var.cex = .7, # addVarianceExplainedToBiplot(x, xb, dim=c(1,4,2)) - - #' Draw a two-dimensional biplot. #' #' The biplot is the central way to create a joint plot of elements and constructs. Depending on the parameters chosen @@ -1397,6 +1392,14 @@ addVarianceExplainedToBiplot2d <- function(x, dim = c(1, 2, 3), var.cex = .7, #' irrespective of their value on the `map.dim` dimension. #' @param c.label.col.left,c.label.col.right Explicit color values for left and right construct poles. #' `NULL` by default. Will overwrite `c.label.col`. +#' @param c.color.preferred Logical or `NULL`. If `TRUE`, construct pole labels are colored by +#' preference status: green for the preferred pole, red for +#' the non-preferred pole, and dark gray for neutral or undefined. +#' Overrides `c.label.col.left` and `c.label.col.right` when +#' enabled. If `NULL` (the default), auto-detects: colors are +#' shown whenever preferred poles have been set via +#' [preferredPoles()] or [preferredPolesByIdeal()]. +#' Set to `FALSE` to suppress colorization. #' @param c.label.cex Size of the construct labels. The default is `.7`. #' Two values can be entered that will create a size ramp. The values of #' `map.dim` are mapped onto the ramp. @@ -1530,6 +1533,10 @@ addVarianceExplainedToBiplot2d <- function(x, dim = c(1, 2, 3), var.cex = .7, #' biplot2d(boeker, outer.positioning = F) # no positioning of con.-labels #' #' biplot2d(boeker, c.labels.devangle = 20) # only con. within 20 degree angle +#' +#' # colorize construct poles by preference +#' x <- preferredPolesByIdeal(boeker, "ideal self") +#' biplot2d(x, c.color.preferred = TRUE) #' } #' biplot2d <- function(x, dim = c(1, 2), map.dim = 3, @@ -1551,6 +1558,7 @@ biplot2d <- function(x, dim = c(1, 2), map.dim = 3, c.label.col = "black", c.label.col.left = NULL, c.label.col.right = NULL, + c.color.preferred = NULL, c.label.cex = .7, c.color.map = c(.4, 1), # e.cex.map=.7, @@ -1587,6 +1595,18 @@ biplot2d <- function(x, dim = c(1, 2), map.dim = 3, g = g, h = h, col.active = col.active, col.passive = col.passive, ... ) + # auto-detect: colorize if preferred poles are defined in the repgrid object + if (is.null(c.color.preferred)) { + c.color.preferred <- any(!is.na(preferredPoles(x))) + } + if (isTRUE(c.color.preferred)) { + pref_colors <- preferred_pole_colors(x) + # Note: internal label ordering in prepareBiplotData has right pole labels + # at type "cl" position and left pole labels at type "cr" position, + # so we swap left/right here to match. + c.label.col.left <- pref_colors$right + c.label.col.right <- pref_colors$left + } x <- prepareBiplotData(x, dim = dim, map.dim = map.dim, e.label.cex = e.label.cex, c.label.cex = c.label.cex, @@ -1832,7 +1852,6 @@ biplotSlaterPseudo3d <- function(x, center = 1, g = 1, h = 1, ...) { } - #' Plot an eigenstructure analysis (ESA) biplot in 2D. #' #' The ESA is a special type of biplot suggested by Raeithel (e.g. 1998). @@ -1927,8 +1946,6 @@ biplotEsaPseudo3d <- function(x, center = 4, g = 1, h = 1, ...) { } - - # ////////////////////////////////////////////////////////// # x <- boeker diff --git a/R/repgrid-ratings.r b/R/repgrid-ratings.r index b1ef28d2..2b7601e6 100644 --- a/R/repgrid-ratings.r +++ b/R/repgrid-ratings.r @@ -5,7 +5,6 @@ # ////////////////////////////////////////////////////////////////////////////// - # sets up an array of proper dimension and dim names to be filled with ratings # if no dimensions are supplied, the proper dimensions are calculated from # the present number of elements and constructs @@ -71,7 +70,6 @@ r.setRatings <- function(x, scores = NA, rows = NA, cols = NA, layer = 1, ...) { # - # a <- array(NA, c(3, 3, 3)) # ,,1 = coupled ratings; decoupled ratings: ,,2 left pole ,,3 right pole # dimnames(a) <- list(constructs=NULL, elements=NULL, # set up layers for coupled and decoupled rating # layer=c("coupled", "left pole decoupled", "right pole decoupled")) @@ -141,7 +139,6 @@ r.makeNewElementColumn <- function(x, pos = NA) { # x <- r.makeNewElementColumn(x, pos=1) - r_makeNewConstructRow <- function(x, pos = NA) { if (is.na(pos[1] & length(pos) == 1)) pos <- nrow(x@ratings) + 1 if (!is.numeric(pos) | pos > nrow(x@ratings) + 1 | pos < 1) { @@ -216,7 +213,6 @@ r.changeRatingsOrder <- function(x, order = NA, along = 1) { # r.changeRatingsOrder(x, 3:1, a=2) - r.deleteRatingsRow <- function(x, pos = NA) { if (!inherits(x, "repgrid")) { # check if x is repgrid object stop("Object x must be of class 'repgrid'.") @@ -269,7 +265,6 @@ r.deleteRatings <- function(x, rows = NA, cols = NA) { # r.deleteRatings(rg,1) - # r.swopRatingsRows <- function(x, pos1, pos2){ # if(!inherits(x, "repgrid")) # check if x is repgrid object # stop("Object x must be of class 'repgrid'.") diff --git a/R/rgl-3d.r b/R/rgl-3d.r index cdadd575..16c7d8be 100644 --- a/R/rgl-3d.r +++ b/R/rgl-3d.r @@ -48,7 +48,6 @@ rglDrawStandardEllipses <- function(max.dim = 1, lwd = 1, col = "black") { } - rglDrawElementPoints <- function(coords, dim = 1:3, e.radius = .1, e.sphere.col = "black", ...) { if (!requireNamespace("rgl", quietly = TRUE)) { stop("The 'rgl' package is required to use OpenRepGrid's 3D features => please install 'rgl'.", call. = FALSE) @@ -288,7 +287,6 @@ biplot3dBase2 <- function(x, dim = 1:3, labels.e = TRUE, labels.c = TRUE, lines. } - #' Draw grid in rgl (3D device). #' #' The 3D biplot opens an interactive @@ -572,8 +570,6 @@ home <- function(view = 1, theta = NULL, phi = NULL) { } - - # ////////////////////////////////////////////////////////////////////////////// ### EXAMPLES ### # ////////////////////////////////////////////////////////////////////////////// @@ -600,8 +596,6 @@ home <- function(view = 1, theta = NULL, phi = NULL) { # lines3d(c(0,0), c(0,0), c(0, 1)) - - # mouseTrackballOrigin <- function(button = 1, dev = cur3d(), origin=c(0,0,0) ) { # width <- height <- rotBase <- NULL # userMatrix <- list() diff --git a/R/utils-import.r b/R/utils-import.r index 0b662780..d65a4758 100644 --- a/R/utils-import.r +++ b/R/utils-import.r @@ -286,15 +286,16 @@ interleave <- function(..., append.source = TRUE, sep = ": ", drop = FALSE) { # function errbar form Hmisc package by Frank E Harrell Jr. # errbar <- function( - x, y, yplus, yminus, cap = 0.015, main = NULL, sub = NULL, - xlab = as.character(substitute(x)), ylab = if (is.factor(x) || - is.character(x)) { - "" - } else { - as.character(substitute(y)) - }, - add = FALSE, lty = 1, type = "p", ylim = NULL, lwd = 1, pch = 16, - Type = rep(1, length(y)), ...) { + x, y, yplus, yminus, cap = 0.015, main = NULL, sub = NULL, + xlab = as.character(substitute(x)), ylab = if (is.factor(x) || + is.character(x)) { + "" + } else { + as.character(substitute(y)) + }, + add = FALSE, lty = 1, type = "p", ylim = NULL, lwd = 1, pch = 16, + Type = rep(1, length(y)), ... +) { if (is.null(ylim)) { ylim <- range(y[Type == 1], yplus[Type == 1], yminus[Type == 1], na.rm = TRUE) @@ -395,8 +396,6 @@ errbar <- function( # } - - # ////////////////////////////////////////////////////////////////////////////// ## Optimal Box-Cox transformation according to ## a grid-based maximization of the correlation diff --git a/R/utils.r b/R/utils.r index 5317e1f4..959596c4 100644 --- a/R/utils.r +++ b/R/utils.r @@ -317,7 +317,6 @@ insertAt <- function(index.base, index.insert, side = "pre") { } - # insertAt(1:4, c(1,3)) # insertAt(c(1,2,3,4), c(1,3), side="pre") # insertAt(c(1,2,3,4), c(1,2), side="pre") @@ -338,7 +337,6 @@ insertAt <- function(index.base, index.insert, side = "pre") { # insertAt(numeric(0), c(1,3), side="post") - # There was once question on r-help asking if apply could be used with a progress bar. # The plyr package provides several apply like functions also including progress bars, # so one could have a look here and use a plyr function instead of apply if possible. @@ -350,9 +348,6 @@ insertAt <- function(index.base, index.insert, side = "pre") { # ISSUES/TODO: MARGIN argument not always correct when vector like c(1,2) is used - - - #' apply with a progress bar #' #' Can be used like standard base:::apply. The only thing @@ -405,7 +400,6 @@ apply_pb <- function(X, MARGIN, FUN, ...) { # head(apply_pb(df, 1, sd)) - #' lapply with a progress bar #' #' Can be used like standard base:::lapply. The only thing @@ -446,7 +440,6 @@ lapply_pb <- function(X, FUN, ...) { # head(lapply_pb(l, mean)) - #' sapply with a progress bar #' #' Can be used like standard base:::sapply. The only thing @@ -536,8 +529,6 @@ trim_val <- function(x, minmax = c(-Inf, Inf), na = FALSE) { } - - #' recycle vector to given length #' #' @param vec vector to be recycled @@ -582,7 +573,6 @@ recycle <- function(vec, length, na.fill = FALSE) { } - #' variation of recycle that recycles one vector x or y to the length of the #' longer one #' @@ -611,8 +601,6 @@ recycle2 <- function(x, y, na.fill = FALSE) { } - - #' generate a random words #' #' randomWords generates a vector of random words taken from a small @@ -707,7 +695,6 @@ orderByString <- function(x, y) { } - ### Thanks to Marc Schwartz for supplying the code for the Somer's d measure # Calculate Concordant Pairs in a table @@ -789,7 +776,6 @@ calc.Sd <- function(x) { # calc.Sd(m) # correct - # ellipse and angle code from: Dr P.D.M. Macdonald # http://www.math.mcmaster.ca/peter/s4c03/s4c03_0506/classnotes/DrawingEllipsesinR.pdf diff --git a/man/biplot2d.Rd b/man/biplot2d.Rd index c3f610c5..eb29aa0a 100644 --- a/man/biplot2d.Rd +++ b/man/biplot2d.Rd @@ -24,6 +24,7 @@ biplot2d( c.label.col = "black", c.label.col.left = NULL, c.label.col.right = NULL, + c.color.preferred = NULL, c.label.cex = 0.7, c.color.map = c(0.4, 1), c.points.devangle = 91, @@ -148,6 +149,15 @@ irrespective of their value on the \code{map.dim} dimension.} \item{c.label.col.left, c.label.col.right}{Explicit color values for left and right construct poles. \code{NULL} by default. Will overwrite \code{c.label.col}.} +\item{c.color.preferred}{Logical or \code{NULL}. If \code{TRUE}, construct pole labels are colored by +preference status: green for the preferred pole, red for +the non-preferred pole, and dark gray for neutral or undefined. +Overrides \code{c.label.col.left} and \code{c.label.col.right} when +enabled. If \code{NULL} (the default), auto-detects: colors are +shown whenever preferred poles have been set via +\code{\link[=preferredPoles]{preferredPoles()}} or \code{\link[=preferredPolesByIdeal]{preferredPolesByIdeal()}}. +Set to \code{FALSE} to suppress colorization.} + \item{c.label.cex}{Size of the construct labels. The default is \code{.7}. Two values can be entered that will create a size ramp. The values of \code{map.dim} are mapped onto the ramp. @@ -325,6 +335,10 @@ biplot2d(boeker, flipaxes = c(T, T)) # flip x and y axis biplot2d(boeker, outer.positioning = F) # no positioning of con.-labels biplot2d(boeker, c.labels.devangle = 20) # only con. within 20 degree angle + +# colorize construct poles by preference +x <- preferredPolesByIdeal(boeker, "ideal self") +biplot2d(x, c.color.preferred = TRUE) } } diff --git a/man/df_construct_columns.Rd b/man/df_construct_columns.Rd index 9bc8101c..c722f34d 100644 --- a/man/df_construct_columns.Rd +++ b/man/df_construct_columns.Rd @@ -27,7 +27,7 @@ importDataframe(df_construct_columns, format = "construct_columns", rmin = 1, rm \seealso{ \code{\link[=importDataframe]{importDataframe()}} -Other grid dataframes: +Other grid dataframes: \code{\link{df_element_columns}}, \code{\link{df_long}} } diff --git a/man/df_element_columns.Rd b/man/df_element_columns.Rd index 9ffb8272..9a4c5ad1 100644 --- a/man/df_element_columns.Rd +++ b/man/df_element_columns.Rd @@ -26,7 +26,7 @@ importDataframe(df_element_columns) \seealso{ \code{\link[=importDataframe]{importDataframe()}} -Other grid dataframes: +Other grid dataframes: \code{\link{df_construct_columns}}, \code{\link{df_long}} } diff --git a/man/df_long.Rd b/man/df_long.Rd index 12bfcd34..b01961ea 100644 --- a/man/df_long.Rd +++ b/man/df_long.Rd @@ -29,7 +29,7 @@ importDataframe(df_long, format = "long") \seealso{ \code{\link[=importDataframe]{importDataframe()}} -Other grid dataframes: +Other grid dataframes: \code{\link{df_construct_columns}}, \code{\link{df_element_columns}} } diff --git a/tests/testthat/_snaps/biplot/biplot2d-preferred-colors.svg b/tests/testthat/_snaps/biplot/biplot2d-preferred-colors.svg new file mode 100644 index 00000000..8cb3dc74 --- /dev/null +++ b/tests/testthat/_snaps/biplot/biplot2d-preferred-colors.svg @@ -0,0 +1,212 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +wanderlust +balanced +dreamy +playful +introvert +isolated +excluded +depressed +technical +passive +selfish +indifferent +emotional +quarrelsome +home oriented +get along with conflicts +dispassionate +serious +extrovert +sociable +closely integrated +practically oriented +artistic +discursive +socially minded +open minded +scientific +peaceful + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +self +self before illness +childhood self +self as dreamer +self with delusion +mother +karl +irene +elizabeth +martin +kurt +george +ideal self +father +therapist + + +Dim 1: 42% +Dim 2: 22.2% + + diff --git a/tests/testthat/test-basicops.R b/tests/testthat/test-basicops.R index 0893a7d1..e3bd3153 100644 --- a/tests/testthat/test-basicops.R +++ b/tests/testthat/test-basicops.R @@ -47,7 +47,6 @@ test_that("reverse works correctly", { }) - test_that("extract element by name", { x <- boeker[, 1:2] y <- boeker[, c("self", "ideal self")] diff --git a/tests/testthat/test-import-export.R b/tests/testthat/test-import-export.R index 90f0da59..0831d8df 100644 --- a/tests/testthat/test-import-export.R +++ b/tests/testthat/test-import-export.R @@ -28,7 +28,6 @@ test_that("importTxt - RATINGS", { }) - # EXCEL -------------------------------------------- test_that("export-import - roundtrip", { diff --git a/tests/testthat/test-indexes.R b/tests/testthat/test-indexes.R index 8b870eca..7f9d00c4 100644 --- a/tests/testthat/test-indexes.R +++ b/tests/testthat/test-indexes.R @@ -122,7 +122,6 @@ test_that("indexBieri works correctly", { }) - test_that("indexDDI works correctly", { files <- system.file("extdata", c("dep_grid_walker_1988_1.xlsx", "dep_grid_walker_1988_2.xlsx"), package = "OpenRepGrid") diff --git a/tests/testthat/test-preferred-pole.R b/tests/testthat/test-preferred-pole.R index 5f695859..c03f304c 100644 --- a/tests/testthat/test-preferred-pole.R +++ b/tests/testthat/test-preferred-pole.R @@ -17,3 +17,43 @@ test_that("preferredPoles", { preferredPoles(x) <- NA expect_equal(preferredPoles(x), rep_len(NA_character_, nc)) }) + + +test_that("preferred_pole_colors returns correct colors", { + x <- boeker + nc <- nrow(x) + + # set mixed preferences + prefs <- c("left", "right", "none", "both", NA) + prefs <- rep_len(prefs, nc) + preferredPoles(x) <- prefs + + colors <- preferred_pole_colors(x) + + # left preferred -> left green, right red + + expect_equal(colors$left[1], "green") + expect_equal(colors$right[1], "red") + + # right preferred -> left red, right green + expect_equal(colors$left[2], "red") + expect_equal(colors$right[2], "green") + + # none -> both dark grey + expect_equal(colors$left[3], grey(.4)) + expect_equal(colors$right[3], grey(.4)) + + # both -> both green + expect_equal(colors$left[4], "green") + expect_equal(colors$right[4], "green") + + # NA -> both dark grey + expect_equal(colors$left[5], grey(.4)) + expect_equal(colors$right[5], grey(.4)) + + # custom colors + colors2 <- preferred_pole_colors(x, col_preferred = "blue", col_nonpreferred = "orange", col_neutral = "white") + expect_equal(colors2$left[1], "blue") + expect_equal(colors2$right[1], "orange") + expect_equal(colors2$left[3], "white") +}) diff --git a/tests/testthat/test_biplot.R b/tests/testthat/test_biplot.R index f468b3ad..167a941d 100644 --- a/tests/testthat/test_biplot.R +++ b/tests/testthat/test_biplot.R @@ -14,4 +14,11 @@ test_that("biplots work", { biplotPseudo3d(boeker) } expect_doppelganger("biplotPseudo3d", create_biplotPseudo3d) + + create_biplot2d_preferred <- function() { + set.seed(0) + x <- preferredPolesByIdeal(boeker, "ideal self") + biplot2d(x, c.color.preferred = TRUE) + } + expect_doppelganger("biplot2d-preferred-colors", create_biplot2d_preferred) })