Skip to main content
  • Home
  • Development
  • Documentation
  • Donate
  • Operational login
  • Browse the archive

swh logo
SoftwareHeritage
Software
Heritage
Archive
Features
  • Search

  • Downloads

  • Save code now

  • Add forge now

  • Help

https://github.com/cran/FSelector
17 June 2021, 02:54:51 UTC
  • Code
  • Branches (34)
  • Releases (0)
  • Visits
    • Branches
    • Releases
    • HEAD
    • refs/heads/master
    • refs/tags/0.15
    • refs/tags/0.17
    • refs/tags/0.18
    • refs/tags/0.19
    • refs/tags/0.20
    • refs/tags/0.21
    • refs/tags/0.31
    • refs/tags/0.32
    • refs/tags/0.33
    • refs/tags/R-2.10.0
    • refs/tags/R-2.10.1
    • refs/tags/R-2.11.0
    • refs/tags/R-2.11.1
    • refs/tags/R-2.12.0
    • refs/tags/R-2.12.1
    • refs/tags/R-2.12.2
    • refs/tags/R-2.13.0
    • refs/tags/R-2.13.1
    • refs/tags/R-2.13.2
    • refs/tags/R-2.14.0
    • refs/tags/R-2.14.1
    • refs/tags/R-2.14.2
    • refs/tags/R-2.15.0
    • refs/tags/R-2.15.1
    • refs/tags/R-2.15.2
    • refs/tags/R-2.15.3
    • refs/tags/R-2.9.0
    • refs/tags/R-2.9.1
    • refs/tags/R-2.9.2
    • refs/tags/R-3.0.0
    • refs/tags/R-3.0.1
    • refs/tags/R-3.0.2
    • refs/tags/R-3.0.3
    No releases to show
  • dae20ad
  • /
  • R
  • /
  • selector.relief.R
Raw File Download
Take a new snapshot of a software origin

If the archived software origin currently browsed is not synchronized with its upstream version (for instance when new commits have been issued), you can explicitly request Software Heritage to take a new snapshot of it.

Use the form below to proceed. Once a request has been submitted and accepted, it will be processed as soon as possible. You can then check its processing state by visiting this dedicated page.
swh spinner

Processing "take a new snapshot" request ...

Permalinks

To reference or cite the objects present in the Software Heritage archive, permalinks based on SoftWare Hash IDentifiers (SWHIDs) must be used.
Select below a type of object currently browsed in order to display its associated SWHID and permalink.

  • content
  • directory
  • revision
  • snapshot
origin badgecontent badge Iframe embedding
swh:1:cnt:0ab390150b1204ea0758e146f9a6b53e20943d13
origin badgedirectory badge Iframe embedding
swh:1:dir:c3b38683b095dd84575aacc4c4f3431f35c040d5
origin badgerevision badge
swh:1:rev:893e2d90fd8569e5f0295334c9a1844e95d7911b
origin badgesnapshot badge
swh:1:snp:0f920b1e114986636ba2e45b5c1a83473fb6cf12
Citations

This interface enables to generate software citations, provided that the root directory of browsed objects contains a citation.cff or codemeta.json file.
Select below a type of object currently browsed in order to generate citations for them.

  • content
  • directory
  • revision
  • snapshot
Generate software citation in BibTex format (requires biblatex-software package)
Generating citation ...
Generate software citation in BibTex format (requires biblatex-software package)
Generating citation ...
Generate software citation in BibTex format (requires biblatex-software package)
Generating citation ...
Generate software citation in BibTex format (requires biblatex-software package)
Generating citation ...
Tip revision: 893e2d90fd8569e5f0295334c9a1844e95d7911b authored by Piotr Romanski on 11 April 2009, 00:00:00 UTC
version 0.18
Tip revision: 893e2d9
selector.relief.R
### RELIEF
# classification and regression
# continous and discrete data
relief <- function(formula, data, neighbours.count = 5, sample.size = 10) {
	# uses parent.env
	find_neighbours <- function(instance_idx) {
		instance = new_data[instance_idx,, drop = FALSE]

		# for every other instance
		for(current_idx in 1:instances_count) {
			if(instance_idx == current_idx)
				next()
			current_instance = new_data[current_idx,, drop = FALSE]
			if(is.na(current_instance[1, 1]))
				next()
			
			dist = instance_distance(instance, current_instance)
			
			if(classification)
				class_no = which(classes == current_instance[[1]])
			else
				class_no = 1
			if(nn_stored_count[class_no] < neighbours.count) {
				nn_stored_count[class_no] <<- nn_stored_count[class_no] + 1
				n_array[class_no, nn_stored_count[class_no], ] <<- c(dist, current_idx)
			} else {
				max_idx = which.max(n_array[class_no, , 1])
				max_value = n_array[class_no, max_idx, 1]
				if(dist < max_value) {
					n_array[class_no, max_idx, ] <<- c(dist, current_idx)
				}
			}
		}
	}
	
	# uses parent.env
	update_weights <- function(instance_idx) {
		instance = new_data[instance_idx,, drop = FALSE]
		instance_class = instance[1, 1]
		instance_class_no = which(classes == instance_class)
		
		if(classification) {
			# for each attribute
			for(attr_idx in 1:attributes_count) {
				col_idx = attr_idx + 1
				
				# nearest hits
				hits_sum = 0
				if(nn_stored_count[instance_class_no] > 0) {
					hits_sum = sum(sapply(1:nn_stored_count[instance_class_no], function(n_idx) {
							n_instance_idx = n_array[instance_class_no, n_idx, 2]
							n_instance = new_data[n_instance_idx,, drop = FALSE]
							return(field_distance(col_idx, instance, n_instance))
						}))
					hits_sum = hits_sum / nn_stored_count[instance_class_no]
				}
				
				# nearest misses
				misses_sum = 0
				if(class_count > 1) {
					misses_sum = sum(sapply((1:class_count)[-instance_class_no], function(class_no) {
							class_misses_sum = 0
							if(nn_stored_count[class_no] > 0) {
								class_misses_sum = sum(sapply(1:nn_stored_count[class_no], function(n_idx) {
										n_instance_idx = n_array[class_no, n_idx, 2]
										n_instance = new_data[n_instance_idx,, drop = FALSE]
										return(field_distance(col_idx, instance, n_instance))
									}))
								class_misses_sum = class_misses_sum * class_prob[class_no] / nn_stored_count[class_no]
							}
							return(class_misses_sum)
						}))
					
					
					misses_sum = misses_sum / (1 - class_prob[instance_class_no])
				}
				results[attr_idx] <<- results[attr_idx] - hits_sum + misses_sum
			}
		} else {
			if(nn_stored_count[1] > 0) {
				for(n_idx in 1:nn_stored_count[1]) {
					n_instance_idx = n_array[1, n_idx, 2]
					n_instance = new_data[n_instance_idx,, drop = FALSE]
					class_diff = field_distance(1, instance, n_instance)
					ndc <<- ndc + class_diff / nn_stored_count[1]
					for(attr_idx in 1:attributes_count) {
						col_idx = attr_idx + 1
						attr_diff_norm = field_distance(col_idx, instance, n_instance) / nn_stored_count[1]
						nda[attr_idx] <<- nda[attr_idx] + attr_diff_norm
						ndcda[attr_idx] <<- ndcda[attr_idx] + class_diff * attr_diff_norm
					}
				}
			}
		}
	}
	
	# parameters: data.frame, data.frame
	instance_distance <- function(instance1, instance2) {
		len = dim(instance1)[2]
		if(len != dim(instance2)[2])
			stop("Instances of different lengths")
		if(len <= 1)
			stop("Too few attributes")
		
		result = sapply(2:len, function(i) {
				return(field_distance(i, instance1, instance2))
			})
		#return(sqrt(sum(result ^ 2))) #sqrt not needed
		res = sum(result ^ 2)
		if(is.na(res)) {
			stop("Internal error. Distance NA.")
		}
		return(res)
	}
	
	# uses parent.env
	# parameters: index, data.frame, data.frame
	field_distance <- function(col_idx, instance1, instance2) {
		value1 = instance1[1, col_idx]
		value2 = instance2[1, col_idx]
		attr_idx = col_idx - 1 # skip class
		
		if(is.factor(value1) && is.factor(value2)) {
			if(is.na(value1) && is.na(value2)) {
				if(classification)
					return(1 - sum(p_val_in_class[[attr_idx]][, instance1[1, 1]] * p_val_in_class[[attr_idx]][, instance2[1, 1]]))
				else
					return(1 - p_same_val[[attr_idx]])
			} else if(is.na(value1) || is.na(value2)) {
				if(is.na(value1)) {
					known_value = value2
					unknown_class = instance1[1, 1]
				} else {
					known_value = value1
					unknown_class = instance2[1, 1]
				}
				if(classification)
					return(1 - p_val_in_class[[attr_idx]][known_value, unknown_class])
				else
					return(1 - p_val[[attr_idx]][known_value])
			} else if(value1 == value2) {
				return(0)
			} else { #if(value1 != value2)
				return(1)
			}
		} else if(is.numeric(value1) && is.numeric(value2)) {
			if(is.na(value1) && is.na(value2)) {
				return(1)
			} else if(is.na(value1)) {
				return(max(value2, 1 - value2))
			} else if(is.na(value2)) {
				return(max(value1, 1 - value1))
			} else {
				return(abs(value1 - value2))
			}		
		} else {
			stop("Unsupported value type")
		}
	}

	new_data = get.data.frame.from.formula(formula, data)
	new_data = normalize.min.max(new_data)
	
	# for discrete classes
	class_vector = NULL
	class_count = NULL
	class_prob = NULL
	classes = NULL
	p_val_in_class = NULL
	p_val = NULL
	p_same_val = NULL
	
	# for continous class
	ndc = NULL
	nda = NULL
	ndcda = NULL
	
	results = NULL
	n_array = NULL
	nn_stored_count = NULL
	classification = NULL
	sample_instances_idx = NULL

	instances_count = dim(new_data)[1]
	attributes_count = dim(new_data)[2] - 1
	attr_names = dimnames(new_data)[[2]][-1]
	
	if(neighbours.count < 1) {
		neighbours.count = 1
		warning(paste("Assumed: neighbours.count = ", neighbours.count))
	}

	if(sample.size < 1) {
		warning(paste("Assumed: sample.size = ", sample.size))
		sample.size = 1
		sample_instances_idx = sample(1:instances_count, 1)
	} else if(sample.size > instances_count) {
		warning(paste("Assumed: sample.size = ", sample.size))
		sample.size = instances_count
		sample_instances_idx = 1:instances_count
	} else {
		sample_instances_idx = sort(sample(1:instances_count, sample.size, replace=TRUE))
	}
	
	classification = is.factor(new_data[[1]])
	if(classification) {
		class_vector = new_data[[1]]
		class_prob = table(class_vector)
		class_prob = class_prob / sum(class_prob)
		classes = names(class_prob)
		class_count = length(classes)
		
		p_val_in_class = lapply(new_data[-1], function(vec) {
				if(!is.factor(vec) || !any(is.na(vec)))
					return(NULL)
				tab = table(vec, class_vector)
				return(apply(tab, 2, function(x) {
						s = sum(x) 
						if(s == 0)
							return(x)
						else
							return(x / s)
					}))
			})
	} else {
		class_count = 1
		ndc = 0
		nda = array(0, attributes_count)
		ndcda = array(0, attributes_count)
	
		p_val = lapply(new_data[-1], function(vec) {
				if(!is.factor(vec) || !any(is.na(vec)))
					return(NULL)
				tab = table(vec)
				if(sum(tab) != 0) {
					tab = tab / sum(tab)
				}
				return(tab)
			})
		p_same_val = lapply(p_val, function(attr) {
				if(is.null(attr))
					return(NULL)
				return(sum(attr ^ 2))
			})
	}

	n_array = array(0, c(class_count, neighbours.count, 2))
	nn_stored_count = array(0, class_count)
	results = rep(0, attributes_count)

	sapply(sample_instances_idx, function(current_instance_idx) {
		current_instance = new_data[current_instance_idx,, drop = FALSE]
		if(is.na(current_instance[[1]]))
			return(NULL)
		
		nn_stored_count[] <<- 0
		n_array[] <<- Inf
		find_neighbours(current_instance_idx)
		update_weights(current_instance_idx)
	})
	

	if(classification) {
		results = results / sample.size
		return(data.frame(attr_importance = results, row.names = attr_names))
	} else {
		results = ndcda / ndc - ((nda - ndcda) / (sample.size - ndc))
		results = data.frame(attr_importance = results, row.names = attr_names)
		#results = normalize.min.max(results)
		return(results)
	}
	
}

back to top

Software Heritage — Copyright (C) 2015–2025, The Software Heritage developers. License: GNU AGPLv3+.
The source code of Software Heritage itself is available on our development forge.
The source code files archived by Software Heritage are available under their own copyright and licenses.
Terms of use: Archive access, API— Contact— JavaScript license information— Web API