text:
Rebol [
	Title: "CSSR"
	Purpose: "A Style Sheet Dialect that generates CSS"
	Version: 0.1.7
	Date: 17-Jun-2013
	Author: "Christopher Ross-Gill"
	Name: 'cssr
	Type: 'module
	Exports: [to-css]
]

to-css: use [ruleset parser ??][

ruleset: context [
	; Values
	values: copy []
	unset: func [key [word!]][remove-each [k value] values [k = key]]
	set: func [key [word!] value [any-type!]][
		unset key repend values [key value]
	]

	; Values that are zero or more
	colors: copy []
	lengths: copy []
	; images: copy []
	transitions: copy []
	transformations: copy []
	; spacing: copy []

	enspace: func [value][join " " value]

	form-color: func [value [tuple! word!]][
		enspace either value/4 [
			["rgba(" value/1 "," value/2 "," value/3 "," either integer? value: value/4 / 255 [value][round/to value 0.01] ")"]
		][
			["rgb(" value/1 "," value/2 "," value/3")"]
		]
	]

	form-number: func [value [number!] unit [word! string! none!]][
		enspace case [
			value = 0 ["0"]
			unit [join value unit]
			value [form value]
		]
	]

	form-value: func [values /local value choices][
		any [
			switch value: take values [
				em pt px deg vw vh [form-number take values value]
				pct [form-number take values "%"]
				* [form-number take values none]
				| [","]
				radial [enspace ["radial-gradient(" remove form-values values ")"]]
				linear [enspace ["linear-gradient(" remove form-values values ")"]]
			]
			switch type?/word value [
				integer! decimal! [form-number value 'px]
				pair! [rejoin [form-number value/x 'px form-number value/y 'px]]
				time! [form-number value/second 's]
				tuple! [form-color value]
				string! [enspace mold value]
				url! file! [enspace [{url('} value {')}]]
				path! [enspace [{url("data:} form value {;base64,} enbase/base take values 64 {")}]]
			]
			enspace value
		]
	]

	form-transform: func [transform [block!] /local name direction][
		; [
		; 	  'translate direction length
		; 	| 'rotate angle opt ['origin percent percent]
		; 	| 'scale [direction number | 1 2 number]
		; ]

		switch/default take transform [
			translate [
				enspace [
					"translate" uppercase form take transform
					"(" next form-value transform ")"
				]
			]
			rotate [
				enspace ["rotate(" next form-value transform ")"]
			]
			scale [
				enspace [
					"scale" either word? transform/1 [uppercase form take transform][""]
					"(" next form-number take transform none either tail? transform [""][
						"," form-number take transform none
					] ")"
				]
			]
		][keep mold head insert transform name]
	]

	form-values: func [values [block!]][
		rejoin collect [
			while [not tail? values][keep form-value values]
		]
	]

	form-property: func [property [word!] values [string! block!] /vendors /inline prefix][
		if block? values [values: form-values values]
		rejoin collect [
			if any [vendors found? find [transition box-sizing transform-style transition-delay] property][
				foreach prefix [-webkit- -moz- -ms- -o-][
					keep form-property to word! join prefix form property values
				]
			]
			if prefix [insert next values prefix]
			keep ["^/^-" property ":" values ";"]
		]
	]

	render: has [value][
		; sort/skip values 2
		while [value: take lengths][
			value: compose [(value)]
			case [
				not find values 'width [set 'width value]
				not find values 'height [set 'height value]
			]
		]
		while [value: take colors][
			value: compose [(value)]
			case [
				not find values 'color [set 'color value]
				not find values 'background-color [set 'background-color value]
			]
		]
		rejoin collect [
			keep "{"
			foreach [property values] values [
				case [
					find [opacity] property [
						if tail? next values [insert values '*]
					]
					all [
						property = 'background-image
						find [radial linear] values/1
					][
						foreach prefix [-webkit- -moz- -ms- -o-][
							keep form-property/inline property copy values prefix
						]
					]

				]
				switch/default property [][
					keep form-property property values
				]
			]
			foreach transform transformations [
				transform: form-transform transform
				keep form-property/vendors 'transform transform
			]
			unless empty? transitions [
				keep form-property/vendors 'transition rejoin next collect [
					foreach transition transitions [
						keep ","
						keep form-values transition
					]
				]
			]
			keep "^/}"
		]
	]

	new: does [
		make self [
			values: copy []
			colors: copy []
			lengths: copy []
			; dimensions: copy []
			; images: copy []
			transitions: copy []
			transformations: copy []
			spacing: copy []
		]
	]
]

parser: context [
	google-fonts-base-url: http://fonts.googleapis.com/css?family=

	; Storage
	reset?: false
	rules: []
	google-fonts: []

	; Basic Types
	zero: use [zero][
		[set zero integer! (zero: either zero? zero [[]][[end skip]]) zero]
	]
	em: ['em number! | zero]
	pt: ['pt number!]
	px: [opt 'px number!]
	deg: ['deg number! | zero]
	scalar: ['* number! | zero]
	percent: ['pct number! | zero]
	vh: ['vh number! | zero]
	vw: ['vw number! | zero]
	color: [tuple! | named-color]
	time: [time!]
	pair: [pair!]
	binary: [end skip] ; [path! binary!] ; omitted until considered safe
	image: [binary | file! | url!]

	; Optionals
	named-color: [
		'aqua | 'black | 'blue | 'fuchsia | 'gray | 'green |
		'lime | 'maroon | 'navy | 'olive | 'orange | 'purple |
		'red | 'silver | 'teal | 'white | 'yellow
	]
	text-style: ['bold | 'italic | 'underline]
	border-style: ['solid | 'dotted | 'dashed]
	transition-attribute: [
		  'width | 'height | 'top | 'bottom | 'right | 'left | 'z-index
		| 'background | 'color | 'border | 'opacity | 'margin
		| 'transform | 'font | 'indent | 'spacing
	]
	list-styles: [
		  'disc | 'circle | 'square | 'decimal | 'decimal-leading-zero
		| 'lower-roman | 'upper-roman | 'lower-greek | 'lower-latin
		| 'upper-latin | 'armenian | 'georgian | 'lower-alpha | 'upper-alpha
	]
	direction: ['x | 'y | 'z]
	position-x: ['right | 'left | 'center]
	position-y: ['top | 'bottom | 'middle]
	position: [position-y | position-x]
	positions: [position-y position-x | position-y | position-x]
	repeats: ['repeat-x | 'repeat-y | 'repeat ['x | 'y] | 'no-repeat | 'no 'repeat]
	font-name: [string! | 'sans-serif | 'serif | 'monospace]
	length: [em | pt | px | percent | vh | vw]
	angle: [deg]
	number: [scalar | number!]
	box-model: ['block | 'inline 'block | 'inline-block]

	; Capture/Use System
	; parse block [mark ... capture (:captured)]
	mark: capture: captured: none
	use [start extent][
		mark: [start:]
		capture: [extent: (new-line/all captured: copy/part start extent false)]
	]
	emit: func [name [word!] value [any-type!]][
		value: compose [(value)]
		; change all the non-standard words
		foreach [from to][
			[no repeat] 'no-repeat
			[no bold] 'normal
			[no italic] 'normal
			[no underline] 'none
			[inline block] 'inline-block
			[line height] 'line-height
		][
			replace value from to
		]
		current/set name value
	]
	emits: func [name [word!]][
		emit name captured
	]

	; The All-Powerful Selector Rule
	; Must be a way to simplify this.
	selector: use [
		dot-word primary qualifier
		form-element form-selectors
		out selectors selector
	][
		dot-word: use [word continue][
			; Matches only words that begin .something
			[
				set word word!
				(continue: either #"." = take form word [[]][[end skip]])
				continue
			]
		]

		primary: [tag! | issue! | dot-word]
		qualifier: [primary | get-word!]

		form-element: func [element [tag! issue! word! get-word!]][
			either tag? element [to string! element][mold element]
		]

		form-selectors: func [selectors [block!]][
			selectors: collect [
				parse selectors [
					some [mark some qualifier capture (keep/only captured)
					| word! capture (keep captured)]
				]
			]

			selectors: collect [
				while [find selectors 'and][
					keep/only copy/part selectors selectors: find selectors 'and
					selectors: next selectors
				] keep/only copy selectors
			]

			selectors: map-each selector selectors [
				collect [
					foreach selector reverse collect [
						while [find selector 'in][
							keep/only copy/part selector selector: find selector 'in
							keep 'has
							selector: next selector
						] keep/only copy selector
					][keep selector]
				]
			]

			selectors: collect [
				foreach selector selectors [
					parse selector [
						set selector block! (selector: map-each element selector [form-element element])
						any [
							'with mark block! capture (
								selector: collect [
									foreach selector selector [
										foreach element captured/1 [
											keep join selector form-element element
										]
									]
								]
							) |
							'has mark block! capture (
								selector: collect [
									foreach selector selector [
										foreach element captured/1 [
											keep rejoin [selector " " form-element element]
										]
									]
								]
							)
						]
					]
					keep/only selector
				]
			]

			rejoin remove collect [
				foreach selector selectors [
					foreach rule selector [
						keep "," keep "^/"
						keep rule
					]
				]
			]
		]

		selector: [
			some primary any [
				  'with some qualifier
				| 'in some primary
				| 'and selector
			]
		]

		[
			mark
			some primary any [
				  'with some qualifier
				| 'in some primary
				| 'and selector
			] capture
			(repend rules [form-selectors captured current: ruleset/new])
		]
	]

	; Each of the Properties fully BNFed
	property: [
		  mark box-model capture (emits 'display)
		| mark 'border-box capture (emits 'box-sizing)
		| 'min some [
			  'width mark length capture (emits 'min-width)
			| 'height mark length capture (emits 'min-height)
		]
		| 'max some [
			  'width mark length capture (emits 'max-width)
			| 'height mark length capture (emits 'max-height)
		]
		| mark ['min-width | 'min-height | 'max-width | 'max-height] length capture (emits take captured)
		| 'height mark length capture (emits 'height)
		| 'margin [
			mark [
				  1 2 [length opt [length | 'auto]]
				| pair opt [length | pair]
			] capture (emits 'margin)
			|
		] any [
			  'top mark length capture (emits 'margin-top)
			| 'bottom mark length capture (emits 'margin-bottom)
			| 'right mark [length | 'auto] capture (emits 'margin-right)
			| 'left mark [length | 'auto] capture (emits 'margin-left)
		]
		| 'padding [
			mark [
				  1 4 length
				| pair opt [length | pair]
			] capture (emits 'padding)
			|
		] any [
			  'top mark length capture (emits 'padding-top)
			| 'bottom mark length capture (emits 'padding-bottom)
			| 'right mark [length | 'auto] capture (emits 'padding-right)
			| 'left mark [length | 'auto] capture (emits 'padding-left)
		]
		| 'border any [
			  mark 1 4 border-style capture (emits 'border-style)
			| mark 1 4 color capture (emits 'border-color)
			| 'radius [
				some [
					  'top mark 1 2 length capture (
						emits 'border-top-left-radius
						emits 'border-top-right-radius
					)
					| 'bottom mark 1 2 length capture (
						emits 'border-bottom-left-radius
						emits 'border-bottom-right-radius
					)
					| 'right mark 1 2 length capture (
						emits 'border-top-right-radius
						emits 'border-bottom-right-radius
					)
					| 'left mark 1 2 length capture (
						emits 'border-top-left-radius
						emits 'border-bottom-left-radius
					)
					| 'top 'right mark 1 2 length capture (emits 'border-top-right-radius)
					| 'top 'left mark 1 2 length capture (emits 'border-top-left-radius)
					| 'bottom 'right mark 1 2 length capture (emits 'border-bottom-right-radius)
					| 'bottom 'left mark 1 2 length capture (emits 'border-bottom-left-radius)
				]
				| mark 1 2 length capture (emits 'border-radius)
			]
			| mark 1 4 length capture (emits 'border-width)
		]
		| ['radius | 'rounded] mark length capture (emits 'border-radius)
		| 'rounded (emit 'border-radius [em 0.6])
		| 'font any [
			  mark length capture (emits 'font-size)
			| mark some font-name capture (
				captured
				remove head forskip captured 2 [insert captured '|]
				emits 'font-family
			)
			| mark color capture (emits 'color)
			| 'line 'height mark number capture (emits 'line-height)
			| 'spacing mark number capture (emits 'letter-spacing)
			| 'shadow mark pair length color capture (emits 'text-shadow)
			| mark opt 'no 'bold capture (emits 'font-weight)
			| mark opt 'no 'italic capture (emits 'font-style)
			| mark opt 'no 'underline capture (emits 'text-decoration)
			| ['line-through | 'strike 'through] (emit 'text-decoration 'line-through)
		]
		| 'text 'indent mark length capture (emits 'text-indent)
		| 'line 'height mark [length | scalar] capture (emits 'line-height)
		| 'spacing mark number capture (emits 'letter-spacing)
		| mark opt 'no 'bold capture (emits 'font-weight)
		| mark opt 'no 'italic capture (emits 'font-style)
		| mark opt 'no 'underline capture (emits 'text-decoration)
		| ['line-through | 'strike 'through] (emit 'text-decoration 'line-through)
		| 'shadow mark pair length color capture (emits 'box-shadow)
		| 'color mark [color | 'inherit] capture (emits 'color)
		| mark ['relative | 'absolute | 'fixed] capture (emits 'position) any [
			  'top mark length capture (emits 'top)
			| 'bottom mark length capture (emits 'bottom)
			| 'right mark length capture (emits 'right)
			| 'left mark length capture (emits 'left)
		]
		| 'opacity mark number capture (emits 'opacity)
		| mark 'nowrap capture (emits 'white-space)
		| mark 'center capture (emits 'text-align)
		| 'transition any [
			mark transition-attribute time opt time capture (
				append/only current/transitions captured
			)
		]
		| [
			  'delay mark time capture (emits 'transition-delay)
			| mark time opt time transition-attribute capture (
				append/only current/transitions head reverse next reverse captured
			)
			| mark time capture (emits 'transition)
		]
		| some [
			mark [
				  'translate direction length
				| 'rotate angle opt ['origin percent percent]
				| 'scale [['x | 'y] number | 1 2 number]
			] capture (append/only current/transformations captured)
		]
		| mark 'preserve-3d capture (emits 'transform-style)
		| 'hide (emit 'display none)
		| 'float mark position-x capture (emits 'float)
		| 'opaque (emit 'opacity 1)
		| mark 'pointer capture (emits 'cursor)
		| ['canvas | 'background] any [
			  mark color capture (emits 'background-color)
			| mark [file! | url!] (emits 'background-image)
			| mark positions capture (emits 'background-position)
			| mark repeats capture (emits 'background-repeat)
			| mark ['contain | 'cover] capture (emits 'background-size)
			| mark pair capture (
				captured: first captured
				emit 'background-position reduce [
					'pct to integer! captured/x
					'pct to integer! captured/y
				]
			)
		]

		| mark [
			'radial color color capture (
				insert at captured 3 '|
			)
			| 'linear angle color color capture (
				insert at tail captured -2 '|
				insert at tail captured -1 '|
			)
			| 'linear opt 'to positions color color capture (
				unless 'to = captured/2 [insert next captured 'to]
				insert at tail captured -2 '|
				insert at tail captured -1 '|
			)
		] (emits 'background-image)

		; | mark binary capture (emits 'background-image) any [
		; 	  mark positions capture (emits 'background-position)
		; 	| mark repeats capture (emits 'background-repeat)
		; ]
		| mark image capture (emits 'background-image) any [
			  mark positions capture (emits 'background-position)
			| mark pair capture (
				captured: first captured
				emit 'background-position reduce [
					'pct to integer! captured/x
					'pct to integer! captured/y
				]
			)
			| mark repeats capture (emits 'background-repeat)
			| mark ['contain | 'cover] capture (emits 'background-size)
		]
		| 'no ['list opt 'style | 'bullet] (emit 'list-style-type 'none)
		| opt ['list opt 'style | 'bullet] mark list-styles capture (emits 'list-style-type)
		| mark ['inside | 'outside] capture (emits 'list-style-position)

		; Any Singleton Values
		| mark [
			  length capture (append/only current/lengths captured)
			| some color capture (append current/colors captured)
			| time capture (emits 'transition)
			| pair capture (
				emit 'width captured/1/x
				emit 'height captured/1/y
			)
		]
	]

	; Control
	current: value: none
	errors: copy []

	; Format Description
	dialect: [()
		opt ['css/reset (reset?: true)]
		opt [
			'google 'fonts [
				some [
					copy value [string! any issue!]
					(append/only google-fonts value)
					|
					set value url! (
						all [
							value: find/match value google-fonts-base-url
							append google-fonts value
						]
					)
				]
			]
		]

		[selector | (repend rules [["body"] current: ruleset/new])]

		any [
			selector | property

			| set value skip (append errors rejoin ["MISPLACED TOKEN: " mold value])
		]
	]

	; CSS Reset Stylesheet
	reset: to string! decompress 64#{
	eJyNU7Fu2zAQncOvIAwUaQ0pkt0mg4x27pBu3YoMpHiSWFOkTFIOnDT/3kfJNtyi
	RQKI4pF8vHv37lgseRfjUBVFTwfyjyRvatcX5HVdROdMKOoQCk+BYsEZ53y/vin5
	L74uV6tytb5LW/e6Jhuo4tZZ4u+HURpdc+V6oe0HtiwY62JvMi6dOmRc6X3GwyBs
	xsUwGIoZd/In1Zh140VPGetWGe/WGB8xPmHcYtxlfIAP4+rtbnSRsPTACriR0uNf
	e2cPPQylwDcAq9uM1zpBa6eAVQQWqkFkAk73ONYWwK1UGd+BFT7RDxkLvTCAhuj1
	lqbZWYDDKNMPNCLY7oXPGDZGeEEEspGwoVIInCq4dLBHDKMz1jiPmEbIxEGOMTrQ
	KJaNJqNCEsFQS1ZlkCsKaRJnMUSdUHEWLjbOARc7EvAdfTIxFDTwUdfpighaTTft
	XiAZRVFoE1K6knCHNbodIRrHfPaevII4T26nufUupch6skjNCpTLjXEYEduPEkQC
	ijVdDWPfC3/IWNQoG4e9BYdRaQd1wMTxZ3aF3VbbipcbdjWgNtq280I6j4Cz3Tgb
	86Cf0ESrsnx33KlQng6tGLHeU0pSmFwY3cKdFIGMtrRhL6xY8q/fv93forfCYMQh
	984Qn5oW6XnUAYG49O4xkA8cEv+t2FmpP5Q5qsX+J9GFQkdNUsJHEtXcq4lfql86
	SXzzjnTbIbVVOpk7ZD4LUCAezPEdTfcumn2XQJMd/gWoJCFTunwglWimjtydz3bz
	VvJUQ15KCl9fby5WJ8dTCybcXKS8dsaIIb3xk3UuYI63XJ+K+sLY3NtVlffuKW9c
	PYZcW5uIaIsm+hEPA31eTMVZPLwGm529jsPL7PUb/DXa0OKBf+FvC8Kfj01abk6t
	W26ODV1ukOxvKxG8Kj8FAAA=
	}

	; Output
	render: does [
		rejoin collect [
			keep {/* CSSR Output */^/}
			if all [
				block? google-fonts
				not empty? google-fonts
			][
				keep "^/@import url ('"
				keep mold join google-fonts-base-url collect [
					repeat font length? google-fonts [
						unless font = 1 [keep "|"]
						case [
							url? google-fonts/:font [
								keep google-fonts/:font
							]
							block? google-fonts/:font [
								keep replace/all mold to url! take google-fonts/:font "%20" "+"
								repeat variant length? google-fonts/:font [
									keep back change to url! mold google-fonts/:font/:variant either variant = 1 [":"][","]
								]
							]
						]
					]
				]
				keep "');^/"
			]
			if reset? [
				keep "^//** CSS Reset Begin */^/^/"
				keep reset
				keep "/* CSS Reset End **/^/"
			]
			keep "^//** CSSR Output Begin */^/^/"
			foreach [selector rule] rules [
				keep selector
				keep " "
				keep rule/render
				keep "^/"
			]
			keep "^/^//* CSSR Output End **/^/"
		]
	]

	; Is Modular
	new: does [
		make parser [
			reset?: false
			google-fonts: copy []
			rules: copy []
			errors: copy []
			current: ruleset/new
			value: none
		]
	]
]

??: use [mark][[mark: (probe new-line/all copy/part mark 8 false)]]

to-css: func [dialect [file! url! string! block!] /local out][
	case/all [
		file? dialect [dialect: load dialect]
		url? dialect [dialect: load dialect]
		string? dialect [dialect: load dialect]
		not block? dialect [make error! "No Dialect!"]
	]

	out: parser/new
	if parse dialect out/dialect [
		out/render
	]
]

]

max_stars_repo_name: draegtun/Scripts

max_issues_repo_name: draegtun/Scripts

max_forks_repo_name: draegtun/Scripts


text:
#' Useful labeller functions
#'
#' Labeller functions are in charge of formatting the strip labels of
#' facet grids and wraps. Most of them accept a `multi_line`
#' argument to control whether multiple factors (defined in formulae
#' such as `~first + second`) should be displayed on a single
#' line separated with commas, or each on their own line.
#'
#' `label_value()` only displays the value of a factor while
#' `label_both()` displays both the variable name and the factor
#' value. `label_context()` is context-dependent and uses
#' `label_value()` for single factor faceting and
#' `label_both()` when multiple factors are
#' involved. `label_wrap_gen()` uses [base::strwrap()]
#' for line wrapping.
#'
#' `label_parsed()` interprets the labels as plotmath
#' expressions. [label_bquote()] offers a more flexible
#' way of constructing plotmath expressions. See examples and
#' [bquote()] for details on the syntax of the
#' argument.
#'
#' @section Writing New Labeller Functions:
#'
#'   Note that an easy way to write a labeller function is to
#'   transform a function operating on character vectors with
#'   [as_labeller()].
#'
#'   A labeller function accepts a data frame of labels (character
#'   vectors) containing one column for each factor. Multiple factors
#'   occur with formula of the type `~first + second`.
#'
#'   The return value must be a rectangular list where each 'row'
#'   characterises a single facet. The list elements can be either
#'   character vectors or lists of plotmath expressions. When multiple
#'   elements are returned, they get displayed on their own new lines
#'   (i.e., each facet gets a multi-line strip of labels).
#'
#'   To illustrate, let's say your labeller returns a list of two
#'   character vectors of length 3. This is a rectangular list because
#'   all elements have the same length. The first facet will get the
#'   first elements of each vector and display each of them on their
#'   own line. Then the second facet gets the second elements of each
#'   vector, and so on.
#'
#'   If it's useful to your labeller, you can retrieve the `type`
#'   attribute of the incoming data frame of labels. The value of this
#'   attribute reflects the kind of strips your labeller is dealing
#'   with: `"cols"` for columns and `"rows"` for rows. Note
#'   that [facet_wrap()] has columns by default and rows
#'   when the strips are switched with the `switch` option. The
#'   `facet` attribute also provides metadata on the labels. It
#'   takes the values `"grid"` or `"wrap"`.
#'
#'   For compatibility with [labeller()], each labeller
#'   function must have the `labeller` S3 class.
#'
#' @param labels Data frame of labels. Usually contains only one
#'   element, but faceting over multiple factors entails multiple
#'   label variables.
#' @param multi_line Whether to display the labels of multiple factors
#'   on separate lines.
#' @param sep String separating variables and values.
#' @param width Maximum number of characters before wrapping the strip.
#' @family facet
#' @seealso [labeller()], [as_labeller()],
#'   [label_bquote()]
#' @examples
#' mtcars$cyl2 <- factor(mtcars$cyl, labels = c("alpha", "beta", "gamma"))
#' p <- ggplot(mtcars, aes(wt, mpg)) + geom_point()
#'
#' # The default is label_value
#' p + facet_grid(. ~ cyl, labeller = label_value)
#'
#' \donttest{
#' # Displaying both the values and the variables
#' p + facet_grid(. ~ cyl, labeller = label_both)
#'
#' # Displaying only the values or both the values and variables
#' # depending on whether multiple factors are facetted over
#' p + facet_grid(am ~ vs+cyl, labeller = label_context)
#'
#' # Interpreting the labels as plotmath expressions
#' p + facet_grid(. ~ cyl2)
#' p + facet_grid(. ~ cyl2, labeller = label_parsed)
#' }
#' @name labellers
NULL

collapse_labels_lines <- function(labels) {
  out <- do.call("Map", c(list(paste, sep = ", "), labels))
  list(unname(unlist(out)))
}

#' @rdname labellers
#' @export
label_value <- function(labels, multi_line = TRUE) {
  labels <- lapply(labels, as.character)
  if (multi_line) {
    labels
  } else {
    collapse_labels_lines(labels)
  }
}
# Should ideally not have the 'function' class here, but this is
# currently needed for Roxygen
class(label_value) <- c("function", "labeller")

# Helper for label_both
label_variable <- function(labels, multi_line = TRUE) {
  if (multi_line) {
    row <- as.list(names(labels))
  } else {
    row <- list(paste(names(labels), collapse = ", "))
  }
  lapply(row, rep, nrow(labels) %||% length(labels[[1]]))
}

#' @rdname labellers
#' @export
label_both <- function(labels, multi_line = TRUE, sep = ": ") {
  value <- label_value(labels, multi_line = multi_line)
  variable <- label_variable(labels, multi_line = multi_line)

  if (multi_line) {
    out <- vector("list", length(value))
    for (i in seq_along(out)) {
      out[[i]] <- paste(variable[[i]], value[[i]], sep = sep)
    }
  } else {
    value <- do.call("paste", c(value, sep = ", "))
    variable <- do.call("paste", c(variable, sep = ", "))
    out <- Map(paste, variable, value, sep = sep)
    out <- list(unname(unlist(out)))
  }

  out
}
class(label_both) <- c("function", "labeller")

#' @rdname labellers
#' @export
label_context <- function(labels, multi_line = TRUE, sep = ": ") {
  if (length(labels) == 1) {
    label_value(labels, multi_line)
  } else {
    label_both(labels, multi_line)
  }
}
class(label_context) <- c("function", "labeller")

#' @rdname labellers
#' @export
label_parsed <- function(labels, multi_line = TRUE) {
  labels <- label_value(labels, multi_line = multi_line)
  if (multi_line) {
    # Using unname() and c() to return a cleaner and easily testable
    # object structure
    lapply(unname(labels), lapply, function(values) {
      c(parse(text = as.character(values)))
    })
  } else {
    lapply(labels, function(values) {
      values <- paste0("list(", values, ")")
      lapply(values, function(expr) c(parse(text = expr)))
    })
  }
}
class(label_parsed) <- c("function", "labeller")

find_names <- function(expr) {
  if (is.call(expr)) {
    unlist(lapply(expr[-1], find_names))
  } else if (is.name(expr)) {
    as.character(expr)
  }
}

#' Label with mathematical expressions
#'
#' `label_bquote()` offers a flexible way of labelling
#' facet rows or columns with plotmath expressions. Backquoted
#' variables will be replaced with their value in the facet.
#'
#' @param rows Backquoted labelling expression for rows.
#' @param cols Backquoted labelling expression for columns.
#' @param default Unused, kept for compatibility.
#' @seealso \link{labellers}, [labeller()],
#' @export
#' @examples
#' # The variables mentioned in the plotmath expression must be
#' # backquoted and referred to by their names.
#' p <- ggplot(mtcars, aes(wt, mpg)) + geom_point()
#' p + facet_grid(vs ~ ., labeller = label_bquote(alpha ^ .(vs)))
#' p + facet_grid(. ~ vs, labeller = label_bquote(cols = .(vs) ^ .(vs)))
#' p + facet_grid(. ~ vs + am, labeller = label_bquote(cols = .(am) ^ .(vs)))
label_bquote <- function(rows = NULL, cols = NULL,
                         default) {
  cols_quoted <- substitute(cols)
  rows_quoted <- substitute(rows)
  has_warned <- FALSE

  fun <- function(labels) {
    quoted <- resolve_labeller(rows_quoted, cols_quoted, labels)
    if (is.null(quoted)) {
      return(label_value(labels))
    }

    evaluate <- function(...) {
      params <- list(...)

      # Mapping `x` to the first variable for backward-compatibility,
      # but only if there is no facetted variable also named `x`
      if ("x" %in% find_names(quoted) && !"x" %in% names(params)) {
        if (!has_warned) {
          warn("Referring to `x` is deprecated, use variable name instead")
          # The function is called for each facet so this avoids
          # multiple warnings
          has_warned <<- TRUE
        }
        params$x <- params[[1]]
      }

      eval(substitute(bquote(expr, params), list(expr = quoted)))
    }
    list(do.call("Map", c(list(f = evaluate), labels)))
  }

  structure(fun, class = "labeller")
}
utils::globalVariables(c("x", "."))

#' @rdname labellers
#' @export
label_wrap_gen <- function(width = 25, multi_line = TRUE) {
  fun <- function(labels) {
    labels <- label_value(labels, multi_line = multi_line)
    lapply(labels, function(x) {
      x <- strwrap(x, width = width, simplify = FALSE)
      vapply(x, paste, character(1), collapse = "\n")
    })
  }
  structure(fun, class = "labeller")
}

is_labeller <- function(x) inherits(x, "labeller")

resolve_labeller <- function(rows, cols, labels) {
  if (is.null(cols) && is.null(rows)) {
    abort("Supply one of rows or cols")
  }
  if (attr(labels, "facet") == "wrap") {
    # Return either rows or cols for facet_wrap()
    if (!is.null(cols) && !is.null(rows)) {
      abort("Cannot supply both rows and cols to facet_wrap()")
    }
    cols %||% rows
  } else {
    if (attr(labels, "type") == "rows") {
      rows
    } else {
      cols
    }
  }
}

#' Coerce to labeller function
#'
#' This transforms objects to labeller functions. Used internally by
#' [labeller()].
#' @param x Object to coerce to a labeller function. If a named
#'   character vector, it is used as a lookup table before being
#'   passed on to `default`. If a non-labeller function, it is
#'   assumed it takes and returns character vectors and is applied to
#'   the labels. If a labeller, it is simply applied to the labels.
#' @param multi_line Whether to display the labels of multiple factors
#'   on separate lines. This is passed to the labeller function.
#' @param default Default labeller to process the labels produced by
#'   lookup tables or modified by non-labeller functions.
#' @seealso [labeller()], \link{labellers}
#' @keywords internal
#' @export
#' @examples
#' p <- ggplot(mtcars, aes(disp, drat)) + geom_point()
#' p + facet_wrap(~am)
#'
#' # Rename labels on the fly with a lookup character vector
#' to_string <- as_labeller(c(`0` = "Zero", `1` = "One"))
#' p + facet_wrap(~am, labeller = to_string)
#'
#' # Quickly transform a function operating on character vectors to a
#' # labeller function:
#' appender <- function(string, suffix = "-foo") paste0(string, suffix)
#' p + facet_wrap(~am, labeller = as_labeller(appender))
#'
#' # If you have more than one faceting variable, be sure to dispatch
#' # your labeller to the right variable with labeller()
#' p + facet_grid(cyl ~ am, labeller = labeller(am = to_string))
as_labeller <- function(x, default = label_value, multi_line = TRUE) {
  force(x)
  fun <- function(labels) {
    labels <- lapply(labels, as.character)

    # Dispatch multi_line argument to the labeller function instead of
    # supplying it to the labeller call because some labellers do not
    # support it.
    default <- dispatch_args(default, multi_line = multi_line)

    if (is_labeller(x)) {
      x <- dispatch_args(x, multi_line = multi_line)
      x(labels)
    } else if (is.function(x)) {
      default(lapply(labels, x))
    } else if (is.character(x)) {
      default(lapply(labels, function(label) x[label]))
    } else {
      default(labels)
    }
  }
  structure(fun, class = "labeller")
}

#' Construct labelling specification
#'
#' This function makes it easy to assign different labellers to
#' different factors. The labeller can be a function or it can be a
#' named character vectors that will serve as a lookup table.
#'
#' In case of functions, if the labeller has class `labeller`, it
#' is directly applied on the data frame of labels. Otherwise, it is
#' applied to the columns of the data frame of labels. The data frame
#' is then processed with the function specified in the
#' `.default` argument. This is intended to be used with
#' functions taking a character vector such as
#' [Hmisc::capitalize()].
#'
#' @param ... Named arguments of the form \code{variable =
#'   labeller}. Each labeller is passed to [as_labeller()]
#'   and can be a lookup table, a function taking and returning
#'   character vectors, or simply a labeller function.
#' @param .rows,.cols Labeller for a whole margin (either the rows or
#'   the columns). It is passed to [as_labeller()]. When a
#'   margin-wide labeller is set, make sure you don't mention in
#'   `...` any variable belonging to the margin.
#' @param keep.as.numeric Deprecated. All supplied labellers and
#'   on-labeller functions should be able to work with character
#'   labels.
#' @param .multi_line Whether to display the labels of multiple
#'   factors on separate lines. This is passed to the labeller
#'   function.
#' @param .default Default labeller for variables not specified. Also
#'   used with lookup tables or non-labeller functions.
#' @family facet labeller
#' @seealso [as_labeller()], \link{labellers}
#' @return A labeller function to supply to [facet_grid()] or [facet_wrap()]
#'   for the argument `labeller`.
#' @export
#' @examples
#' \donttest{
#' p1 <- ggplot(mtcars, aes(x = mpg, y = wt)) + geom_point()
#'
#' # You can assign different labellers to variables:
#' p1 + facet_grid(
#'   vs + am ~ gear,
#'   labeller = labeller(vs = label_both, am = label_value)
#' )
#'
#' # Or whole margins:
#' p1 + facet_grid(
#'   vs + am ~ gear,
#'   labeller = labeller(.rows = label_both, .cols = label_value)
#' )
#'
#' # You can supply functions operating on strings:
#' capitalize <- function(string) {
#'   substr(string, 1, 1) <- toupper(substr(string, 1, 1))
#'   string
#' }
#' p2 <- ggplot(msleep, aes(x = sleep_total, y = awake)) + geom_point()
#' p2 + facet_grid(vore ~ conservation, labeller = labeller(vore = capitalize))
#'
#' # Or use character vectors as lookup tables:
#' conservation_status <- c(
#'   cd = "Conservation Dependent",
#'   en = "Endangered",
#'   lc = "Least concern",
#'   nt = "Near Threatened",
#'   vu = "Vulnerable",
#'   domesticated = "Domesticated"
#' )
#' ## Source: http://en.wikipedia.org/wiki/Wikipedia:Conservation_status
#'
#' p2 + facet_grid(vore ~ conservation, labeller = labeller(
#'   .default = capitalize,
#'   conservation = conservation_status
#' ))
#'
#' # In the following example, we rename the levels to the long form,
#' # then apply a wrap labeller to the columns to prevent cropped text
#' idx <- match(msleep$conservation, names(conservation_status))
#' msleep$conservation2 <- conservation_status[idx]
#'
#' p3 <- ggplot(msleep, aes(x = sleep_total, y = awake)) + geom_point()
#' p3 +
#'   facet_grid(vore ~ conservation2,
#'     labeller = labeller(conservation2 = label_wrap_gen(10))
#'   )
#'
#' # labeller() is especially useful to act as a global labeller. You
#' # can set it up once and use it on a range of different plots with
#' # different facet specifications.
#'
#' global_labeller <- labeller(
#'   vore = capitalize,
#'   conservation = conservation_status,
#'   conservation2 = label_wrap_gen(10),
#'   .default = label_both
#' )
#'
#' p2 + facet_grid(vore ~ conservation, labeller = global_labeller)
#' p3 + facet_wrap(~conservation2, labeller = global_labeller)
#' }
labeller <- function(..., .rows = NULL, .cols = NULL,
                     keep.as.numeric = NULL, .multi_line = TRUE,
                     .default = label_value) {
  if (!is.null(keep.as.numeric)) {
    .Deprecated(old = "keep.as.numeric")
  }
  dots <- list(...)
  .default <- as_labeller(.default)

  function(labels) {
    if (!is.null(.rows) || !is.null(.cols)) {
      margin_labeller <- resolve_labeller(.rows, .cols, labels)
    } else {
      margin_labeller <- NULL
    }

    if (is.null(margin_labeller)) {
      labellers <- lapply(dots, as_labeller, default = .default)
    } else {
      margin_labeller <- as_labeller(margin_labeller, default = .default,
                                     multi_line = .multi_line)

      # Check that variable-specific labellers do not overlap with
      # margin-wide labeller
      if (any(names(dots) %in% names(labels))) {
        abort(glue(
          "Conflict between .{attr(labels, 'type')} and ",
          glue_collapse(names(dots), ", ", last = " and ")
        ))
      }
    }

    # Apply relevant labeller
    if (is.null(margin_labeller)) {
      # Apply named labeller one by one
      out <- lapply(names(labels), function(label) {
        if (label %in% names(labellers)) {
          labellers[[label]](labels[label])[[1]]
        } else {
          .default(labels[label])[[1]]
        }
      })
      names(out) <- names(labels)
      if (.multi_line) {
        out
      } else {
        collapse_labels_lines(out)
      }
    } else {
      margin_labeller(labels)
    }
  }
}

#' Build facet strips
#'
#' Builds a set of facet strips from a data frame of labels.
#'
#' @param label_df Data frame of labels to place in strips.
#' @param labeller Labelling function.
#' @param theme A theme object.
#' @param horizontal Whether the strips are horizontal (e.g. x facets) or not.
#'
#' @noRd
build_strip <- function(label_df, labeller, theme, horizontal) {
  labeller <- match.fun(labeller)

  # No labelling data, so return empty row/col
  if (empty(label_df)) {
    return(if (horizontal) {
      list(top = NULL, bottom = NULL)
    } else {
      list(left = NULL, right = NULL)
    })
  }

  # Create matrix of labels
  labels <- lapply(labeller(label_df), cbind)
  labels <- do.call("cbind", labels)
  ncol <- ncol(labels)
  nrow <- nrow(labels)

  if (horizontal) {
    grobs_top <- lapply(labels, element_render, theme = theme,
                        element = "strip.text.x.top", margin_x = TRUE,
                        margin_y = TRUE)
    grobs_top <- assemble_strips(matrix(grobs_top, ncol = ncol, nrow = nrow),
                                 theme, horizontal, clip = "on")

    grobs_bottom <- lapply(labels, element_render, theme = theme,
                           element = "strip.text.x.bottom", margin_x = TRUE,
                           margin_y = TRUE)
    grobs_bottom <- assemble_strips(matrix(grobs_bottom, ncol = ncol, nrow = nrow),
                                    theme, horizontal, clip = "on")

    list(
      top = grobs_top,
      bottom = grobs_bottom
    )
  } else {
    grobs_left <- lapply(labels, element_render, theme = theme,
                         element = "strip.text.y.left", margin_x = TRUE,
                         margin_y = TRUE)
    grobs_left <- assemble_strips(matrix(grobs_left, ncol = ncol, nrow = nrow),
                                  theme, horizontal, clip = "on")

    grobs_right <- lapply(labels[, rev(seq_len(ncol(labels))), drop = FALSE],
                          element_render, theme = theme,
                          element = "strip.text.y.right", margin_x = TRUE,
                          margin_y = TRUE)
    grobs_right <- assemble_strips(matrix(grobs_right, ncol = ncol, nrow = nrow),
                                   theme, horizontal, clip = "on")

    list(
      left = grobs_left,
      right = grobs_right
    )
  }
}

#' Grob for strip labels
#'
#' Takes the output from title_spec, adds margins, creates gList with strip
#' background and label, and returns gtable matrix.
#'
#' @param grobs Output from [titleGrob()].
#' @param theme Theme object.
#' @param horizontal Whether the strips are horizontal (e.g. x facets) or not.
#' @param clip should drawing be clipped to the specified cells (‘"on"’),the
#'   entire table (‘"inherit"’), or not at all (‘"off"’).
#'
#' @noRd
assemble_strips <- function(grobs, theme, horizontal = TRUE, clip) {
  if (length(grobs) == 0 || is.zero(grobs[[1]])) return(grobs)

  # Add margins to non-titleGrobs so they behave eqivalently
  grobs[] <- lapply(grobs, function(g) {
    if (inherits(g, "titleGrob")) return(g)
    add_margins(gList(g), grobHeight(g), grobWidth(g), margin_x = TRUE, margin_y = TRUE)
  })

  if (horizontal) {
    height <- max_height(lapply(grobs, function(x) x$heights[2]))
    width <- unit(1, "null")
  } else {
    height <- unit(1, "null")
    width <- max_width(lapply(grobs, function(x) x$widths[2]))
  }
  grobs[] <- lapply(grobs, function(x) {
    # Avoid unit subset assignment to support R 3.2
    x$widths <- unit.c(x$widths[1], width, x$widths[c(-1, -2)])
    x$heights <- unit.c(x$heights[1], height, x$heights[c(-1, -2)])
    x$vp$parent$layout$widths <- unit.c(x$vp$parent$layout$widths[1], width, x$vp$parent$layout$widths[c(-1, -2)])
    x$vp$parent$layout$heights <- unit.c(x$vp$parent$layout$heights[1], height, x$vp$parent$layout$heights[c(-1, -2)])
    x
  })
  if (horizontal) {
    height <- sum(grobs[[1]]$heights)
  } else {
    width <- sum(grobs[[1]]$widths)
  }

  background <- if (horizontal) "strip.background.x" else "strip.background.y"
  background <- element_render(theme, background)

  # Put text on a strip
  grobs[] <- lapply(grobs, function(x) {
    ggname("strip", gTree(children = gList(background, x)))
  })
  apply(grobs, 1, function(x) {
    if (horizontal) {
      mat <- matrix(x, ncol = 1)
    } else {
      mat <- matrix(x, nrow = 1)
    }
    gtable_matrix("strip", mat, rep(width, ncol(mat)), rep(height, nrow(mat)), clip = clip)
  })
}

# Check for old school labeller
check_labeller <- function(labeller) {
  labeller <- match.fun(labeller)
  is_deprecated <- all(c("variable", "value") %in% names(formals(labeller)))

  if (is_deprecated) {
    old_labeller <- labeller
    labeller <- function(labels) {
      Map(old_labeller, names(labels), labels)
    }
    warn(glue(
      "The labeller API has been updated. Labellers taking `variable` ",
      "and `value` arguments are now deprecated. See labellers documentation."))
  }

  labeller
}

ext: r


text:
df.residual.mira <- function(object, ...) {
    fit <- object$analyses[[1]]
    return(df.residual(fit))
}

df.residual.lme <- function(object, ...) {
    return(object$fixDF[["X"]][1])
}

df.residual.mer <- function(object, ...) {
    return(sum(object@dims[2:4] * c(1, -1, -1)) + 1)
}

df.residual.default <- function(object, q = 1.3, ...) {
    df <- object$df.residual
    if (!is.null(df))
        return(df)

    mk <- try(c <- coef(object), silent = TRUE)
    mn <- try(f <- fitted(object), silent = TRUE)
    if (inherits(mk, "try-error") | inherits(mn, "try-error"))
        return(NULL)
    n <- ifelse(is.data.frame(f) | is.matrix(f), nrow(f), length(f))
    k <- length(c)
    if (k == 0 | n == 0)
        return(NULL)
    return(max(1, n - q * k))
}

max_stars_repo_name: JavascriptID/sourcerer-app

max_issues_repo_name: JavascriptID/sourcerer-app

max_forks_repo_name: JavascriptID/sourcerer-app


text:
ybar = 31.2           # sample mean
mu0 = 33            # hypothesized value
sigma = 8.4       # population standard deviation
n = 35                # sample size
z = (ybar- mu0)/(sigma/sqrt(n))
# test statistic

p_value=pnorm(z)
print(p_value)
alpha=0.05
if(p_value>alpha){
  print("we fail to reject H0")
  print(" data do not support the research hypothesis(insufficient evidence).")
}else{
  print("reject H0")
}


text:
# R

a <- 1 + 1

a + 5

an obvious eror

max_stars_repo_name: jacob-brown/programming-notes-book

max_issues_repo_name: jacob-brown/programming-notes-book

max_forks_repo_name: jacob-brown/programming-notes-book


text:
# Name: Marzieh_Farahani
# Project_Title: Time series Forecasting SARIMA
# Date: 10-5-2021

###################################
#           Time series
###################################

# Remove all Variables and Graphics First
getwd()
rm(list=ls())
graphics.off()

---------------------------------------------
# Read the data
births <- scan("http://robjhyndman.com/tsdldata/data/nybirths.dat")

#############
# Identification
#############

# Tranformation the data into an Time series_object

td <- ts(births, frequency=12, start=c(1946,1))

# Plot of the Time series

X11()
plot.ts(td, xlab= "Time", ylab= " ",
        main= "the number of births per month in New York city", col= "blue")
x11()
acf(td, lag.max = 50)

#########################
# Periodicoty Test
########################

# Test if there is no hidden periodicity (ASk about the null and periodic??)

# Raw time series without defining frequency
X11()
TS <- ts(births, start=c(1946,1))
par(mfcol= c(1, 1))
spec.pgram(TS, spans = c(3, 3), log = "no")
spec.pgram(TS, spans = c(5, 5))
x11()
par(mfcol= c(1, 1))
spec.pgram(TS, spans = c(3, 3), log="no")
(frmax <- locator(1))
(fr<-frmax $births)
(tper = 1/fr)

##############################
# Differencing the time series
#############################
X11()
par(mfcol=c(3,1))

y<-log(td)
plot(y, xlab = "Year", ylab= "log-y", main = "The log-births data")

# Visible trend, seasonal component.
# try 12 differencing

dy12 = diff(y, lag = 12)
plot(dy12, xlab = "Year", ylab= "dy12", main = "The diff12-log-births data")

# Take look at ACF
acf(dy12, lag.max = 50)

X11()
par(mfrow=c(3,1))

#-------------------------------------------
###### Still no stationarity
#-------------------------------------------

# More differencing
ddy12 = diff(dy12)
plot(ddy12, xlab = "Year", ylab= "ddy12", main = "The dd12-log-births data")

acf(ddy12, lag.max = 50)

pacf(ddy12, lag.max = 50)

ar(ddy12)

##############
# Estimation
##############

#split the data

(train<-ts(td[1:(length(td)-24)], start = c(1946, 1), frequency = 12))
(test<-ts(td[(length(td)-23):length(td)], start = c(1958, 1), frequency = 12))
window()
plot(train, xlab="Time", ylab="", main="Train Data set")
plot(test, xlab="Time", ylab="", main="Test Data set")

# Estimation the model
# first guess
(try<- arima(train, order = c(1, 0, 3), seasonal = list(order=c(0, 1, 1))))
# Call:
#arima(x = train, order = c(1, 0, 3), seasonal = list(order = c(0, 1, 1)))

#Coefficients:
#       ar1      ma1      ma2      ma3     sma1
#      0.9955  -0.0693  -0.1888  -0.1573  -1.0000
#s.e.  0.0139   0.0920   0.0810   0.0937   0.1083

#sigma^2 estimated as 0.3766:  log likelihood = -137.4,  aic = 286.8
#---------------------------------------------------------------------
(try1<- arima(train, order = c(2, 0, 0), seasonal = list(order=c(0, 1, 1))))
#Call:
#  arima(x = train, order = c(2, 0, 0), seasonal = list(order = c(0, 1, 1)))

#Coefficients:
#         ar1     ar2     sma1
#       0.9457  0.0263  -0.9999
# s.e.  0.0889  0.0896   0.1412

#sigma^2 estimated as 0.4008:  log likelihood = -142.2,  aic = 292.41
#----------------------------------------------------------------------
(try2<- arima(train, order = c(3, 0, 3), seasonal = list(order=c(0, 1, 1))))
#Call:
# arima(x = train, order = c(3, 0, 3), seasonal = list(order = c(0, 1, 1)))

#Coefficients:
#         ar1      ar2     ar3     ma1     ma2      ma3     sma1
#       0.8207  -0.0960  0.2678  0.0881  0.0419  -0.2328  -1.0000
# s.e.  0.4774   0.6437  0.2955  0.4689  0.3025   0.1296   0.1103

#sigma^2 estimated as 0.3721:  log likelihood = -136.71,  aic = 289.42
#---------------------------------------------------------------------
(try3<- arima(train, order = c(0, 1, 3), seasonal = list(order=c(0, 1, 1))))
#Call:
#  arima(x = train, order = c(0, 1, 3), seasonal = list(order = c(0, 1, 1)))

#Coefficients:
#         ma1      ma2      ma3     sma1
#       -0.0651  -0.1849  -0.1556  -0.9656
# s.e.   0.0931   0.0816   0.0946   0.4127

#sigma^2 estimated as 0.3296:  log likelihood = -137.47,  aic = 284.94

##################
#Estimate the model with best AIC
##################

(ts3.fit<-arima(train, order = c(0, 1, 3), seasonal = list(order=c(0, 1, 1))))

# Tests, the residuals are white noise or even normally distributed

x11()
tsdiag(ts3.fit)
ts3.res<-ts3.fit$residuals
var(ts3.res)
par(mfcol=c(2,1))
hist(ts3.res, col = "gray")
qqnorm(ts3.res)
qqline(ts3.res)

#shapiro test
shapiro.test(ts3.res)

--------------------------------
#data:  ts3.res
#W = 0.98517, p-value = 0.1239
-------------------------------

# control spectral analysis
X11()
cpgram(ts3.res, main="Cumulative periodogram of the residuals")
par(mfcol=c(2,1))
spec.pgram(ddy12, spans=c(3,3), log="no", main="Births")
spec.pgram(ts3.res, spans=c(5,5), log="no", main="Residuals: Births data")

####################################
#prediction of the whole time series
####################################

(ts.pred<-predict(ts3.fit,n.ahead = 24))
x11()
plot(train, xlim=c(1946,1959),col="blue",
     ylab="Mean births",
     main="The time series with the left out values,
     predicted values and their 95% confidense bounds",
     xlab="Time [Years]")
lines(test, col="blue",type="o")
lines(ts.pred$pred, col="red", type="o")
lines(ts.pred$pred+2*ts.pred$se, col="red", lty=3)
lines(ts.pred$pred-2*ts.pred$se, col="red", lty=3)


text:
library(fastercaster)

m <- 10000
n <- 1000
x <- runif(m*n)

system.time(as.matrix(x))
system.time(as_matrix(x))

dim(x)

x <- runif(m*n)
system.time(matrix(x, m, n))
system.time(as_matrix(x, m, n))

dim(x)

max_stars_repo_name: wrathematics/fastercaster

max_issues_repo_name: wrathematics/fastercaster

max_forks_repo_name: wrathematics/fastercaster


text:
#' Removes old files from result's folder
#'
#' Get all file names in result's folder, put in dataframe, and remove old ones
#' if name and date are old
#' @param title Title of old file
#' @export
#' @author Sean Brunson

remove_from_folder <- function(title){
    # Get current date:
    current_date <- Sys.Date()

    # Get all file names in result's folder, put in dataframe, and remove old ones
    # if name and date are old:
    all_files <- list.files("results/") %>%
        enframe(name = NULL) %>%
        separate(value, c("name", "date"), sep = " \\(") %>%
        mutate(date = str_remove_all(date, "\\).xlsx")) %>%
        filter(name == title,
               date != current_date)

    # Make files back to original form in order to delete:
    files_to_delete <- all_files %>%
        mutate(file_name = paste0("results/", name, " ", "(", date, ").xlsx")) %>%
        select(file_name) %>%
        .[[1]]

    # Print message:
    print(paste0("Deleting ", files_to_delete))

    # Delete files in all_files:
    unlink(files_to_delete)
}

#' Saves data to Excel file
#'
#' Takes results and creates and saves to Excel file
#' @inheritParams openxlsx::writeData
#' @param results Results
#' @param title Title of new Excel file
#' @param worksheet_name Name of worksheet
#' @export
#' @author Sean Brunson

save_to_excel <- function(results, title, worksheet_name = NULL){
    # Get current date and create file name:
    current_date <- Sys.Date()
    file_name <- paste0("results/", title, " ", "(", current_date, ").xlsx")

    # Create Excel workbook and add worksheet:
    wb <- openxlsx::createWorkbook(file_name)
    if(is.null(worksheet_name)){
        openxlsx::addWorksheet(wb, title)
    } else{
        openxlsx::addWorksheet(wb, worksheet_name)
    }

    # Write and save data to Excel:
    if(is.null(worksheet_name)){
        openxlsx::writeData(wb, title, results, rowNames = FALSE)
    } else{
        openxlsx::writeData(wb, worksheet_name, results, rowNames = FALSE)
    }

    openxlsx::saveWorkbook(wb, file_name, overwrite = TRUE)

    # Print message:
    print(paste0("Saved to: ", file_name))

    # Delete old files:
    remove_from_folder(title)
}

#' Adds data to Excel file
#'
#' Takes results and adds it to existing Excel file. Only used after
#' \code{\link{save_to_excel}}
#' @inheritParams openxlsx::writeData
#' @param results Results
#' @param title Title of new Excel file
#' @param worksheet_name Name of worksheet
#' @export
#' @author Sean Brunson

add_additional_worksheet <- function(results, title, worksheet_name){
    # Get current date and create file name:
    current_date <- Sys.Date()
    file_name <- paste0("results/", title, " ", "(", current_date, ").xlsx")

    # Create Excel workbook and add worksheet:
    wb <- openxlsx::loadWorkbook(file_name)
    openxlsx::addWorksheet(wb, worksheet_name)

    # Write and save data to Excel:
    openxlsx::writeData(wb, worksheet_name, results, rowNames = FALSE)
    openxlsx::saveWorkbook(wb, file_name, overwrite = TRUE)

    # Print message:
    print(paste0("Added worksheet to: ", file_name))
}

max_stars_repo_name: SeanBrunson/easyresearch

max_issues_repo_name: SeanBrunson/easyresearch

max_forks_repo_name: SeanBrunson/easyresearch