R/repgrid-ratings.r

In OpenRepGrid: Tools to Analyze Repertory Grid Data

#//////////////////////////////////////////////////////////////////////////////
#
#      				           basic ratings operations				 
#
#//////////////////////////////////////////////////////////////////////////////



# sets up an array of proper dimension and dim names to be filled with ratings
# if no dimensions are supplied, the proper dimensions are calculated from
# the present number of elements and constructs
initRatingArray <- function(x, nconstructs=NULL, nelements=NULL){
	if(!inherits(x, "repgrid")) 							# check if x is repgrid object
		stop("Object x must be of class 'repgrid'.")
	if(is.null(nelements))
		nelements <- length(x@elements)
	if(is.null(nconstructs))
		nconstructs <- length(x@constructs)		
	ratingArray <- array(NA, c(nconstructs, nelements, 3)) 				# ,,1 = coupled ratings; decoupled ratings: ,,2 left pole  ,,3 right pole
	dimnames(ratingArray) <- list(constructs=NULL, elements=NULL,			# set up layers for coupled and decoupled rating
								  layer=c("coupled", "left pole decoupled", "right pole decoupled"))
	x@ratings <- ratingArray
	x
}

#x <- initRatingArray(x, 10, 10)


# mat 	matrix or dataframe 
r.setRatings <- function(x, scores=NA, rows=NA, cols=NA, layer=1, ...){
	if(!inherits(x, "repgrid")) 									# check if x is repgrid object
		stop("Object x must be of class 'repgrid'.")
	if(is.list(scores) & !is.data.frame(scores))
		stop("scores must not be a list.")
	if(!(is.matrix(scores) | is.data.frame(scores) | is.vector(scores)))		# check if scores is matrix, dataframe or vector
		stop("scores must be matrix, dataframe or vector.")																
	if(is.data.frame(scores))
	 	scores <- as.matrix(scores)
	if(is.na(rows[1]) & length(rows)==1)
		rows <- 1:nrow(x@ratings)
	if(is.na(cols[1]) & length(cols)==1)
		cols <- 1:ncol(x@ratings)
	if(max(rows) > nrow(x@ratings))
		stop("number of constructs does not exists.")
	if(max(cols) > ncol(x@ratings)){
		stop("number of elements does not exists.")
	}
	x@ratings[rows, cols, layer] <- 
	  as.vector(matrix(as.vector(scores), ncol=length(x@elements), byrow=TRUE))
	x
}

 # rg <- makeEmptyRepgrid()														# make a new repgrid object
 # rg <- initRatingArray(rg, 3,5)													# initialize rating array
 # rg <- setRatings(rg, matrix(1,3,5))												# set whole layer
 # rg <- setRatings(rg, 11:12, r=1:2, c=1)  										# insert a vector
 # rg <- setRatings(rg, matrix(1:4,2), r=1:2, c=1:2, l=2)  						# insert a matrix
 # rg <- setRatings(rg, as.data.frame(matrix(1:4,2)), r=1:2, c=2:3, l=3) 			# insert dataframe
 # 



# a <- array(NA, c(3, 3, 3)) 				# ,,1 = coupled ratings; decoupled ratings: ,,2 left pole  ,,3 right pole
# dimnames(a) <- list(constructs=NULL, elements=NULL,			# set up layers for coupled and decoupled rating
# 							  layer=c("coupled", "left pole decoupled", "right pole decoupled"))
# 
# makeNewElementColumn <- function(a){
# 	el <- array(NA, c(dim(a)[1], 1, dim(a)[3]))
# 	el
# }
# a <- abind(a, makeNewElementColumn(a), along=1)
# 
# 
# makeNewConstructRow <- function(a){
# 	con <- array(NA, c(1, dim(a)[2], dim(a)[3]))
# 	con
# }
# a <- abind(a, makeNewConstructRow(a), along=1)
# 
# 
# x <- makeEmptyRepgrid()
# makeNewElementColumn <- function(x){
# 	a <- x@ratings
# 	elementColumn <- array(NA, c(dim(a)[1], 1, dim(a)[3]))
# 	x@ratings <- abind(a, elementColumn, along=2)
# 	x
# }
# x <- makeNewElementColumn(x)
# 
# x <- makeEmptyRepgrid()
# makeNewConstructRow <- function(a){
# 	a <- x@ratings
# 	constructRow <- array(NA, c(1, dim(a)[2], dim(a)[3]))
# 	x@ratings <- abind(a, constructRow, along=1)
# 	x
# }
# x <- makeNewConstructRow(x)
# 
# 
# 
# 
# makeNewElementColumn <- function(a){
# 	el <- array(NA, c(dim(a)[1], 1, dim(a)[3]))
# 	el
# }
# a <- abind(a, makeNewElementColumn(a), along=2)
# 
# pos <- 6
# index <- insertAt(seq_len(dim(a)[2]), pos)					# insert element column at position pos
# a <- abind(a, makeNewElementColumn(a), along=2)				# attach new column
# a <- a[, c(index$index.base.new, index$index.insert.new), ]	# reorder by pos
# a
#//////////////////////////////////////////////////////////////////////////////


r.makeNewElementColumn <- function(x, pos=NA){
	if(is.na(pos[1]&length(pos)==1)) pos <- ncol(x@ratings) + 1
	if(!is.numeric(pos) | pos > ncol(x@ratings) + 1 | pos < 1)
		stop("pos must be between 1 number of elements plus one.")
	a <- x@ratings
	index <- insertAt(seq_len(dim(a)[2]), pos)					# insert element column at position pos
	elementColumn <- array(NA, c(dim(a)[1], 1, dim(a)[3]))
	a <- abind(a, elementColumn, along=2)
	x@ratings <- a[, c(index$index.base.new, index$index.insert.new), ,drop = FALSE]	# reorder by pos
	x
}
#x <- makeEmptyRepgrid()
#x <- r.makeNewElementColumn(x, pos=1)



r_makeNewConstructRow <- function(x, pos=NA){	
	if(is.na(pos[1]&length(pos)==1)) pos <- nrow(x@ratings)+1
	if(!is.numeric(pos) | pos > nrow(x@ratings)+1 | pos < 1)
		stop("pos must be between 1 number of constructs plus one.")
	a <- x@ratings
	index <- insertAt(seq_len(dim(a)[1]), pos)					# insert construct row at position pos
	constructRow <- array(NA, c(1, dim(a)[2], dim(a)[3]))
	a <- abind(a, constructRow, along=1)
	x@ratings <- a[c(index$index.base.new, index$index.insert.new),, ,drop = FALSE]	# reorder by pos
	x
}
#x <- makeEmptyRepgrid()
#x <- r_makeNewConstructRow(x)


r.addColumns <- function(x, no, position=NA, side="pre"){
	if(!inherits(x, "repgrid")) 							# check if x is repgrid object
		stop("Object x must be of class 'repgrid'.")
	if(!is.numeric(position) & !(length(position)==1 & is.na(position[1])))
		stop("position must be numeric.")
	if(length(position)==1 & is.na(position[1])){
		position <- rep(NA, no)
	}
	#if(length(unique(position)) != length(position))							# is index unique?
	#	stop("position values must be unique.")
	position[is.na(position)] <- seq_along(position[is.na(position)]) + ncol(x@ratings)
	index <- insertAt(seq_len(ncol(x@ratings)), position, side=side)
	tmp <- c(index$index.base.new, index$index.insert.new)
	if(max(tmp) > length(tmp))
		stop("position has values that will create wholes in the element list.")		
	for(i in seq_len(no)){
		 x <- r.makeNewElementColumn(x)				# attach empty columns
	}
	x <- r.changeRatingsOrder(x, order=orderBy(tmp, seq_len(ncol(x@ratings))), along=2)
	x	
}

#r.addColumns(rg, 2, position=c(1,5))@ratings

r.changeRatingsOrder <- function(x, order=NA, along=1){
	if(!inherits(x, "repgrid")) 							# check if x is repgrid object
		stop("Object x must be of class 'repgrid'.")
	if(!along %in% 1:2)
		stop("along must be 1 for rows(constructs) or 2 for columns (elements).")
	if(is.na(order[1]) & length(order)==1){
		if(along==1){
			order <- seq_len(nrow(x@ratings))				# default order along constructs				
		} else if(along==2){
			order <- seq_len(ncol(x@ratings))				# default order along elements		
		}
	}
	if(along==1){											# reorder constructs
		if(nrow(x@ratings) != length(order))
			stop("order must have same length as number of rows (constructs) in ratings exist.")
		x@ratings <- x@ratings[order,,,drop=FALSE]	
	} else if(along==2){									# reorder elements
		if(ncol(x@ratings) != length(order))
			stop("order must have same length as number of cols (elements) in ratings exist.")
			x@ratings <- x@ratings[,order,,drop=FALSE]	
	}
	x
}

# r.changeRatingsOrder(x, 3:1, a=2)



r.deleteRatingsRow <- function(x, pos=NA){
	if(!inherits(x, "repgrid")) 							# check if x is repgrid object
		stop("Object x must be of class 'repgrid'.")
	if(is.na(pos[1])){
		return(x);
		#break
	}
	if(any(pos<0 | pos > nrow(x@ratings)))
		stop("pos must contains values greater than 1 and equal or less than ratings rows.")
	x@ratings <- x@ratings[-pos, , ,drop=FALSE]
	x
}


r.deleteRatingsColumns <- function(x, pos=NA){
	if(!inherits(x, "repgrid")) 							# check if x is repgrid object
		stop("Object x must be of class 'repgrid'.")
	if(is.na(pos[1])){
		return(x);
		#break
	}
	if(any(pos<0 | pos > ncol(x@ratings)))
		stop("pos must contains values greater than 1 and equal or less than ratings columns.")
	x@ratings <- x@ratings[ ,-pos , ,drop=FALSE]
	x
}
#r.deleteRatingsColumns(rg)

# TODO
r.deleteRatings <- function(x, rows=NA, cols=NA){
	if(!inherits(x, "repgrid")) 							# check if x is repgrid object
		stop("Object x must be of class 'repgrid'.")
	if(any(rows<0 | rows > nrow(x@ratings)))
		stop("pos must contains values greater than 1 and equal or less than ratings rows.")
	if(any(rows<0 | rows > nrow(x@ratings)))
		stop("pos must contains values greater than 1 and equal or less than ratings rows.")
	keeprows <- !(seq_len(nrow(x@ratings)) %in% rows)
	keepcols <- !(seq_len(ncol(x@ratings)) %in% cols)
	x@ratings <- x@ratings[keeprows, keepcols, ,drop=FALSE]
	x
}
#r.deleteRatings(x, 1)
#r.deleteRatings(rg,1)



# r.swopRatingsRows <- function(x, pos1, pos2){
#   if(!inherits(x, "repgrid"))               # check if x is repgrid object
#     stop("Object x must be of class 'repgrid'.")
#   if(any(c(pos1, pos2) < 0) | any(c(pos1, pos2)> nrow(x@ratings)))
#     stop("pos1 and pos2 must be bigger than 1 and have number of constructs as a maximum")
#   x@ratings[c(pos1, pos2),,] <- x@ratings[c(pos2, pos1),,] 
#   x
# }
# 
# r.swopRatingsColumns <- function(x, pos1, pos2){
#   if(!inherits(x, "repgrid"))               # check if x is repgrid object
#     stop("Object x must be of class 'repgrid'.")
#   if(any(c(pos1, pos2) < 0) | any(c(pos1, pos2)> ncol(x@ratings)))
#     stop("pos1 and pos2 must be bigger than 1 and have number of elements as a maximum")
#   x@ratings[,c(pos1, pos2),] <- x@ratings[,c(pos2, pos1),] 
#   x
# }
# 
# # str(moveElementTo(x, 1,4))
# r.moveRatingsRowUpwards <- function(x, pos){
#   if(!inherits(x, "repgrid"))               # check if x is repgrid object
#     stop("Object x must be of class 'repgrid'.")
#   if(pos<=1 | pos > nrow(x@ratings)){
#     return(x)   
#   } else {
#     x <- r.swopRatingsRows(x, pos, pos-1) 
#     return(x)
#   }
# }
# 
# r.moveRatingsRowDownwards <- function(x, pos){
#   if(!inherits(x, "repgrid"))               # check if x is repgrid object
#     stop("Object x must be of class 'repgrid'.")
#   if(pos<0 | pos >= nrow(x@ratings)){
#     return(x)   
#   } else {
#     x <- r.swopRatingsRows(x, pos, pos+1) 
#     return(x)
#   }
# }
# 
# 
# 
# # str(moveElementTo(x, 1,4))
# r.moveRatingsColumnLeftwards <- function(x, pos){
#   if(!inherits(x, "repgrid"))               # check if x is repgrid object
#     stop("Object x must be of class 'repgrid'.")
#   if(pos<=1 | pos > ncol(x@ratings)){
#     return(x)   
#   } else {
#     x <- r.swopRatingsColumns(x, pos, pos-1)  
#     return(x)
#   }
# }
# #moveRatingsColumnLeftwards(x, 2)
# 
# r.moveRatingsColumnRightwards <- function(x, pos){
#   if(!inherits(x, "repgrid"))               # check if x is repgrid object
#     stop("Object x must be of class 'repgrid'.")
#   if(pos<0 | pos >= ncol(x@ratings)){
#     return(x)   
#   } else {
#     x <- r.swopRatingsColumns(x, pos, pos+1)  
#     return(x)
#   }
# }